Procházet zdrojové kódy

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.
Ryan Scott před 2 roky
rodič
revize
226119124d
5 změnil soubory, kde provedl 137 přidání a 23 odebrání
  1. 7 0
      doc/org-manual.org
  2. 7 0
      etc/ORG-NEWS
  3. 56 23
      lisp/ob-core.el
  4. 1 0
      lisp/org-attach.el
  5. 66 0
      testing/lisp/test-ob.el

+ 7 - 0
doc/org-manual.org

@@ -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:
 
 

+ 7 - 0
etc/ORG-NEWS

@@ -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

+ 56 - 23
lisp/ob-core.el

@@ -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
-			 result
-			 (org-babel--file-desc (nth 2 info) result)))))
+	   (setq result
+                 (org-babel-result-to-file
+		  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?
-	   (and (buffer-file-name (buffer-base-buffer))
-		(not (string= (expand-file-name default-directory)
-			      (expand-file-name
-			       (file-name-directory
-			        (buffer-file-name (buffer-base-buffer)))))))))
-      (format "[[file:%s]%s]"
-	      (if (and default-directory
-		       (buffer-file-name (buffer-base-buffer)) same-directory?)
-		  (if (eq org-link-file-path-type 'adaptive)
-		      (file-relative-name
-		       (expand-file-name result default-directory)
-		       (file-name-directory
-			(buffer-file-name (buffer-base-buffer))))
-		    (expand-file-name result default-directory))
-		result)
+    (let* ((result-file-name (expand-file-name result))
+           (base-file-name (buffer-file-name (buffer-base-buffer)))
+           (base-directory (and buffer-file-name
+                                (file-name-directory base-file-name)))
+           (same-directory?
+	    (and base-file-name
+	         (not (string= (expand-file-name default-directory)
+			       (expand-file-name
+			        base-directory)))))
+           (request-attachment (eq type 'attachment))
+           (attach-dir (let* ((default-directory base-directory)
+                              (dir (org-attach-dir nil t)))
+                         (when dir
+                           (expand-file-name dir))))
+           (in-attach-dir (and request-attachment
+                               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

+ 1 - 0
lisp/org-attach.el

@@ -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.

+ 66 - 0
testing/lisp/test-ob.el

@@ -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