ob-core.el/babel: Special handling for attachment links in src block

* ob-core.el (org-babel-merge-params): Specifying the symbol 'attach`
or string "'attach" as the value of the `:dir' header now functions as
":dir (org-attach-dir nil t) :mkdirp t".
(org-babel-result-to-file): Optional TYPE argument accepts symbol
'attachment to fixup up paths under `(org-attach-dir)' and use the
link type "attachment:" when that is detected.
(org-babel-insert-result): Pass symbol `attachment' as TYPE to
`org-babel-result-to-file'.
* org-attach.el (org-attach-dir): Added autoload header to simplify
dependencies necessary to support this feature (called in
`org-babel-merge-params').
* test-ob.el (test-ob-core/dir-attach): Added unit test for the new
attach feature.
This commit is contained in:
Ryan Scott 2022-06-10 00:01:37 -07:00 committed by Ihor Radchenko
parent 3baac35b55
commit 226119124d
No known key found for this signature in database
GPG Key ID: 6470762A7DA11D8B
5 changed files with 137 additions and 23 deletions

View File

@ -17542,6 +17542,13 @@ directory with {{{kbd(M-x cd RET DIRECTORY)}}}, and then not setting
variable ~default-directory~. Setting =mkdirp= header argument to variable ~default-directory~. Setting =mkdirp= header argument to
a non-~nil~ value creates the directory, if necessary. a non-~nil~ value creates the directory, if necessary.
Setting =dir= to the symbol ~attach~ or the string ~"'attach"~ will
set =dir= to the directory returned by ~(org-attach-dir)~, set =:mkdir
yes=, and insert any file paths, as when using =:results file=, which
are under the node's attachment directory using =attachment:= links
instead of the usual =file:= links. Any returned path outside of the
attachment directory will use =file:= links as per usual.
For example, to save the plot file in the =Work/= folder of the home For example, to save the plot file in the =Work/= folder of the home
directory---notice tilde is expanded: directory---notice tilde is expanded:

View File

@ -798,6 +798,13 @@ Finally, the closures are only evaluated if they're not overridden for
a source block. This improves efficiency in cases where the result of a source block. This improves efficiency in cases where the result of
a compute-expensive closure would otherwise be discarded. a compute-expensive closure would otherwise be discarded.
*** New special value ~'attach~ for src block =:dir= option
Passing the symbol ~attach~ or string ="'attach"= (with quotes) to the =:dir=
option of a src block is now equivalent to =:dir (org-attach-dir) :mkdir yes=
and any file results with a path descended from the attachment directory will
use =attachment:= style links instead of the standard =file:= link type.
** Miscellaneous ** Miscellaneous
*** =org-bibtex= includes =doi= and =url= entries when exporting to BiBTeX *** =org-bibtex= includes =doi= and =url= entries when exporting to BiBTeX
=doi= and =url= entries have been made optional for some publication =doi= and =url= entries have been made optional for some publication

View File

@ -801,7 +801,8 @@ block."
(let ((*this* (if (not file) result (let ((*this* (if (not file) result
(org-babel-result-to-file (org-babel-result-to-file
file file
(org-babel--file-desc params result))))) (org-babel--file-desc params result)
'attachment))))
(setq result (org-babel-ref-resolve post)) (setq result (org-babel-ref-resolve post))
(when file (when file
(setq result-params (remove "file" result-params)))))) (setq result-params (remove "file" result-params))))))
@ -2298,11 +2299,14 @@ INFO may provide the values of these header arguments (in the
(cond ((stringp result) (cond ((stringp result)
(setq result (org-no-properties result)) (setq result (org-no-properties result))
(when (member "file" result-params) (when (member "file" result-params)
(setq result (org-babel-result-to-file (setq result
result (org-babel-result-to-file
(org-babel--file-desc (nth 2 info) result))))) result
(org-babel--file-desc (nth 2 info) result)
'attachment))))
((listp result)) ((listp result))
(t (setq result (format "%S" result)))) (t (setq result (format "%S" result))))
(if (and result-params (member "silent" result-params)) (if (and result-params (member "silent" result-params))
(progn (message (replace-regexp-in-string "%" "%%" (format "%S" result))) (progn (message (replace-regexp-in-string "%" "%%" (format "%S" result)))
result) result)
@ -2605,27 +2609,49 @@ in the buffer."
(line-beginning-position 2)) (line-beginning-position 2))
(point)))))) (point))))))
(defun org-babel-result-to-file (result &optional description) (defun org-babel-result-to-file (result &optional description type)
"Convert RESULT into an Org link with optional DESCRIPTION. "Convert RESULT into an Org link with optional DESCRIPTION.
If the `default-directory' is different from the containing If the `default-directory' is different from the containing
file's directory then expand relative links." file's directory then expand relative links.
If the optional TYPE is passed as 'attachment` and the path is a
descendant of the DEFAULT-DIRECTORY, the generated link will be
specified as an an \"attachment:\" style link."
(when (stringp result) (when (stringp result)
(let ((same-directory? (let* ((result-file-name (expand-file-name result))
(and (buffer-file-name (buffer-base-buffer)) (base-file-name (buffer-file-name (buffer-base-buffer)))
(not (string= (expand-file-name default-directory) (base-directory (and buffer-file-name
(expand-file-name (file-name-directory base-file-name)))
(file-name-directory (same-directory?
(buffer-file-name (buffer-base-buffer))))))))) (and base-file-name
(format "[[file:%s]%s]" (not (string= (expand-file-name default-directory)
(if (and default-directory (expand-file-name
(buffer-file-name (buffer-base-buffer)) same-directory?) base-directory)))))
(if (eq org-link-file-path-type 'adaptive) (request-attachment (eq type 'attachment))
(file-relative-name (attach-dir (let* ((default-directory base-directory)
(expand-file-name result default-directory) (dir (org-attach-dir nil t)))
(file-name-directory (when dir
(buffer-file-name (buffer-base-buffer)))) (expand-file-name dir))))
(expand-file-name result default-directory)) (in-attach-dir (and request-attachment
result) attach-dir
(string-prefix-p
attach-dir
result-file-name))))
(format "[[%s:%s]%s]"
(pcase type
((and 'attachment (guard in-attach-dir)) "attachment")
(_ "file"))
(if (and request-attachment in-attach-dir)
(file-relative-name result-file-name)
(if (and default-directory
base-file-name same-directory?)
(if (eq org-link-file-path-type 'adaptive)
(file-relative-name
result-file-name
(file-name-directory
base-file-name))
result-file-name)
result))
(if description (concat "[" description "]") ""))))) (if description (concat "[" description "]") "")))))
(defun org-babel-examplify-region (beg end &optional results-switches inline) (defun org-babel-examplify-region (beg end &optional results-switches inline)
@ -2756,10 +2782,17 @@ parameters when merging lists."
(setq exports (funcall merge (setq exports (funcall merge
exports-exclusive-groups exports-exclusive-groups
exports exports
(split-string (split-string
(cond ((and value (functionp value)) (funcall value)) (cond ((and value (functionp value)) (funcall value))
(value value) (value value)
(t "")))))) (t ""))))))
((or '(:dir . attach) '(:dir . "'attach"))
(unless (org-attach-dir nil t)
(error "No attachment directory for element (add :ID: or :DIR: property)"))
(setq params (append
`((:dir . ,(org-attach-dir nil t))
(:mkdirp . "yes"))
(assq-delete-all :dir (assq-delete-all :mkdir params)))))
;; Regular keywords: any value overwrites the previous one. ;; Regular keywords: any value overwrites the previous one.
(_ (setq params (cons pair (assq-delete-all (car pair) params))))))) (_ (setq params (cons pair (assq-delete-all (car pair) params)))))))
;; Handle `:var' and clear out colnames and rownames for replaced ;; Handle `:var' and clear out colnames and rownames for replaced

View File

@ -324,6 +324,7 @@ Shows a list of commands and prompts for another key to execute a command."
(command-execute command) (command-execute command)
(error "No such attachment command: %c" c)))))) (error "No such attachment command: %c" c))))))
;;;###autoload
(defun org-attach-dir (&optional create-if-not-exists-p no-fs-check) (defun org-attach-dir (&optional create-if-not-exists-p no-fs-check)
"Return the directory associated with the current outline node. "Return the directory associated with the current outline node.
First check for DIR property, then ID property. First check for DIR property, then ID property.

View File

@ -1770,6 +1770,72 @@ nil
(file-modes "t.sh") (file-modes "t.sh")
(delete-file "t.sh")))))) (delete-file "t.sh"))))))
(ert-deftest test-ob-core/dir-attach ()
"Test :dir header using special 'attach value"
(should
(org-test-with-temp-text-in-file
"* 'attach Symbol
<point>#+begin_src elisp :dir 'attach :results file
(with-temp-file \"test.txt\" (insert \"attachment testing\n\"))
\"test.txt\"
#+end_src"
(org-id-get-create)
(org-babel-execute-src-block)
(goto-char (org-babel-where-is-src-block-result))
(forward-line)
(and
(file-exists-p (format "%s/test.txt" (org-attach-dir nil t)))
(string= (buffer-substring-no-properties (point) (line-end-position))
"[[attachment:test.txt]]"))))
(should
(org-test-with-temp-text-in-file
"* 'attach String
<point>#+begin_src elisp :dir \"'attach\" :results file
(with-temp-file \"test.txt\" (insert \"attachment testing\n\"))
\"test.txt\"
#+end_src"
(org-id-get-create)
(org-babel-execute-src-block)
(goto-char (org-babel-where-is-src-block-result))
(forward-line)
(and
(file-exists-p (format "%s/test.txt" (org-attach-dir nil t)))
(string= (buffer-substring-no-properties (point) (line-end-position))
"[[attachment:test.txt]]"))))
(should
(org-test-with-temp-text-in-file
"* 'attach with Existing DIR property
:PROPERTIES:
:DIR: custom-attach-dir
:END:
<point>#+begin_src elisp :dir 'attach :results file
(with-temp-file \"test.txt\" (insert \"attachment testing\n\"))
\"test.txt\"
#+end_src"
(message "DIR: %s" (org-attach-dir t))
(org-babel-execute-src-block)
(goto-char (org-babel-where-is-src-block-result))
(forward-line)
(and
(file-exists-p (format "%s/test.txt" (org-attach-dir nil t)))
(string= (buffer-substring-no-properties (point) (line-end-position))
"[[attachment:test.txt]]"))))
(should-error
(org-test-with-temp-text-in-file
"* 'attach with no ID or DIR
<point>#+begin_src elisp :dir 'attach :results file
(with-temp-file \"test.txt\" (insert \"attachment testing\n\"))
\"test.txt\"
#+end_src"
(org-babel-execute-src-block)
(goto-char (org-babel-where-is-src-block-result))
(forward-line)
(and
(file-exists-p (format "%s/test.txt" (org-attach-dir nil t)))
(string= (buffer-substring-no-properties (point) (line-end-position))
"[[attachment:test.txt]]")))))
(ert-deftest test-ob-core/dir-mkdirp () (ert-deftest test-ob-core/dir-mkdirp ()
"Test :mkdirp with :dir header combination." "Test :mkdirp with :dir header combination."
(should-not (should-not