X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/16ddec7e9e6adcf615db097d9627d490ca29208c..37b9099068c10383e959ee366a52a22516846163:/lisp/org/ob-tangle.el

diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el
index 7077a1571e..bfd5a062fc 100644
--- a/lisp/org/ob-tangle.el
+++ b/lisp/org/ob-tangle.el
@@ -1,6 +1,6 @@
 ;;; ob-tangle.el --- extract source code from org-mode files
 
-;; Copyright (C) 2009-2012  Free Software Foundation, Inc.
+;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
 
 ;; Author: Eric Schulte
 ;; Keywords: literate programming, reproducible research
@@ -26,19 +26,20 @@
 ;; Extract the code from source blocks out into raw source-code files.
 
 ;;; Code:
-(require 'ob)
 (require 'org-src)
 (eval-when-compile
   (require 'cl))
 
+(declare-function org-edit-special "org" (&optional arg))
 (declare-function org-link-escape "org" (text &optional table))
+(declare-function org-store-link "org" (arg))
+(declare-function org-open-link-from-string "org" (s &optional arg reference-buffer))
 (declare-function org-heading-components "org" ())
 (declare-function org-back-to-heading "org" (invisible-ok))
 (declare-function org-fill-template "org" (template alist))
 (declare-function org-babel-update-block-body "org" (new-body))
 (declare-function make-directory "files" (dir &optional parents))
 
-;;;###autoload
 (defcustom org-babel-tangle-lang-exts
   '(("emacs-lisp" . "el"))
   "Alist mapping languages to their file extensions.
@@ -113,7 +114,7 @@ result.  The default value is `org-babel-trim'."
 (defun org-babel-find-file-noselect-refresh (file)
   "Find file ensuring that the latest changes on disk are
 represented in the file."
-  (find-file-noselect file)
+  (find-file-noselect file 'nowarn)
   (with-current-buffer (get-file-buffer file)
     (revert-buffer t t t)))
 
@@ -137,69 +138,49 @@ evaluating BODY."
        ,temp-result)))
 (def-edebug-spec org-babel-with-temp-filebuffer (form body))
 
-;;;###autoload
-(defun org-babel-load-file (file)
-  "Load Emacs Lisp source code blocks in the Org-mode FILE.
-This function exports the source code using
-`org-babel-tangle' and then loads the resulting file using
-`load-file'."
-  (interactive "fFile to load: ")
-  (let* ((age (lambda (file)
-		(float-time
-		 (time-subtract (current-time)
-				(nth 5 (or (file-attributes (file-truename file))
-					   (file-attributes file)))))))
-	 (base-name (file-name-sans-extension file))
-	 (exported-file (concat base-name ".el")))
-    ;; tangle if the org-mode file is newer than the elisp file
-    (unless (and (file-exists-p exported-file)
-		 (> (funcall age file) (funcall age exported-file)))
-      (org-babel-tangle-file file exported-file "emacs-lisp"))
-    (load-file exported-file)
-    (message "Loaded %s" exported-file)))
-
 ;;;###autoload
 (defun org-babel-tangle-file (file &optional target-file lang)
   "Extract the bodies of source code blocks in FILE.
 Source code blocks are extracted with `org-babel-tangle'.
 Optional argument TARGET-FILE can be used to specify a default
 export file for all source blocks.  Optional argument LANG can be
-used to limit the exported source code blocks by language."
+used to limit the exported source code blocks by language.
+Return a list whose CAR is the tangled file name."
   (interactive "fFile to tangle: \nP")
   (let ((visited-p (get-file-buffer (expand-file-name file)))
 	to-be-removed)
-    (save-window-excursion
-      (find-file file)
-      (setq to-be-removed (current-buffer))
-      (org-babel-tangle nil target-file lang))
-    (unless visited-p
-      (kill-buffer to-be-removed))))
+    (prog1
+	(save-window-excursion
+	  (find-file file)
+	  (setq to-be-removed (current-buffer))
+	  (org-babel-tangle nil target-file lang))
+      (unless visited-p
+	(kill-buffer to-be-removed)))))
 
 (defun org-babel-tangle-publish (_ filename pub-dir)
   "Tangle FILENAME and place the results in PUB-DIR."
   (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename)))
 
 ;;;###autoload
-(defun org-babel-tangle (&optional only-this-block target-file lang)
+(defun org-babel-tangle (&optional arg target-file lang)
   "Write code blocks to source-specific files.
 Extract the bodies of all source code blocks from the current
-file into their own source-specific files.  Optional argument
-TARGET-FILE can be used to specify a default export file for all
-source blocks.  Optional argument LANG can be used to limit the
-exported source code blocks by language."
+file into their own source-specific files.
+With one universal prefix argument, only tangle the block at point.
+When two universal prefix arguments, only tangle blocks for the
+tangle file of the block at point.
+Optional argument TARGET-FILE can be used to specify a default
+export file for all source blocks.  Optional argument LANG can be
+used to limit the exported source code blocks by language."
   (interactive "P")
   (run-hooks 'org-babel-pre-tangle-hook)
-  ;; possibly restrict the buffer to the current code block
+  ;; Possibly Restrict the buffer to the current code block
   (save-restriction
-    (when only-this-block
-      (unless (org-babel-where-is-src-block-head)
-	(error "Point is not currently inside of a code block"))
-      (save-match-data
-	(unless (or (cdr (assoc :tangle (nth 2 (org-babel-get-src-block-info))))
-		    target-file)
-	  (setq target-file
-		(read-from-minibuffer "Tangle to: " (buffer-file-name)))))
-      (narrow-to-region (match-beginning 0) (match-end 0)))
+    (when (equal arg '(4))
+      (let ((head (org-babel-where-is-src-block-head)))
+	  (if head
+	      (goto-char head)
+	    (user-error "Point is not in a source code block"))))
     (save-excursion
       (let ((block-counter 0)
 	    (org-babel-default-header-args
@@ -207,6 +188,10 @@ exported source code blocks by language."
 		 (org-babel-merge-params org-babel-default-header-args
 					 (list (cons :tangle target-file)))
 	       org-babel-default-header-args))
+	    (tangle-file
+	     (when (equal arg '(16))
+	       (or (cdr (assoc :tangle (nth 2 (org-babel-get-src-block-info 'light))))
+		   (user-error "Point is not in a source code block"))))
 	    path-collector)
 	(mapc ;; map over all languages
 	 (lambda (by-lang)
@@ -225,8 +210,9 @@ exported source code blocks by language."
 	      (lambda (spec)
 		(let ((get-spec (lambda (name) (cdr (assoc name (nth 4 spec))))))
 		  (let* ((tangle (funcall get-spec :tangle))
-			 (she-bang ((lambda (sheb) (when (> (length sheb) 0) sheb))
-				    (funcall get-spec :shebang)))
+			 (she-bang (let ((sheb (funcall get-spec :shebang)))
+                                     (when (> (length sheb) 0) sheb)))
+			 (tangle-mode (funcall get-spec :tangle-mode))
 			 (base-name (cond
 				     ((string= "yes" tangle)
 				      (file-name-sans-extension
@@ -238,14 +224,15 @@ exported source code blocks by language."
 				      (if (and ext (string= "yes" tangle))
 					  (concat base-name "." ext) base-name))))
 		    (when file-name
-		      ;; possibly create the parent directories for file
-		      (when ((lambda (m) (and m (not (string= m "no"))))
-			     (funcall get-spec :mkdirp))
-			(make-directory (file-name-directory file-name) 'parents))
+		      ;; Possibly create the parent directories for file.
+		      (let ((m (funcall get-spec :mkdirp))
+			    (fnd (file-name-directory file-name)))
+			(and m fnd (not (string= m "no"))
+			     (make-directory fnd 'parents)))
 		      ;; delete any old versions of file
-		      (when (and (file-exists-p file-name)
-				 (not (member file-name path-collector)))
-			(delete-file file-name))
+		      (and (file-exists-p file-name)
+			   (not (member file-name (mapcar #'car path-collector)))
+			   (delete-file file-name))
 		      ;; drop source-block to file
 		      (with-temp-buffer
 			(when (fboundp lang-f) (ignore-errors (funcall lang-f)))
@@ -262,24 +249,35 @@ exported source code blocks by language."
 			    (insert content)
 			    (write-region nil nil file-name))))
 		      ;; if files contain she-bangs, then make the executable
-		      (when she-bang (set-file-modes file-name #o755))
+		      (when she-bang
+			(unless tangle-mode (setq tangle-mode #o755)))
 		      ;; update counter
 		      (setq block-counter (+ 1 block-counter))
-		      (add-to-list 'path-collector file-name)))))
+		      (add-to-list 'path-collector
+				   (cons file-name tangle-mode)
+				   nil
+				   (lambda (a b) (equal (car a) (car b))))))))
 	      specs)))
-	 (org-babel-tangle-collect-blocks lang))
+	 (if (equal arg '(4))
+	     (org-babel-tangle-single-block 1 t)
+	   (org-babel-tangle-collect-blocks lang tangle-file)))
 	(message "Tangled %d code block%s from %s" block-counter
 		 (if (= block-counter 1) "" "s")
 		 (file-name-nondirectory
-		  (buffer-file-name (or (buffer-base-buffer) (current-buffer)))))
+		  (buffer-file-name
+		   (or (buffer-base-buffer) (current-buffer)))))
 	;; run `org-babel-post-tangle-hook' in all tangled files
 	(when org-babel-post-tangle-hook
 	  (mapc
 	   (lambda (file)
 	     (org-babel-with-temp-filebuffer file
 	       (run-hooks 'org-babel-post-tangle-hook)))
-	   path-collector))
-	path-collector))))
+	   (mapcar #'car path-collector)))
+	;; set permissions on tangled files
+	(mapc (lambda (pair)
+		(when (cdr pair) (set-file-modes (car pair) (cdr pair))))
+	      path-collector)
+	(mapcar #'car path-collector)))))
 
 (defun org-babel-tangle-clean ()
   "Remove comments inserted by `org-babel-tangle'.
@@ -299,10 +297,10 @@ references."
 (defvar org-bracket-link-regexp)
 (defun org-babel-spec-to-string (spec)
   "Insert SPEC into the current file.
-Insert the source-code specified by SPEC into the current
-source code file.  This function uses `comment-region' which
-assumes that the appropriate major-mode is set.  SPEC has the
-form
+
+Insert the source-code specified by SPEC into the current source
+code file.  This function uses `comment-region' which assumes
+that the appropriate major-mode is set.  SPEC has the form:
 
   (start-line file link source-name params body comment)"
   (let* ((start-line (nth 0 spec))
@@ -317,9 +315,8 @@ form
 		     (string= comments "yes") (string= comments "noweb")))
 	 (link-data (mapcar (lambda (el)
 			      (cons (symbol-name el)
-				    ((lambda (le)
-				       (if (stringp le) le (format "%S" le)))
-				     (eval el))))
+				    (let ((le (eval el)))
+                                      (if (stringp le) le (format "%S" le)))))
 			    '(start-line file link source-name)))
 	 (insert-comment (lambda (text)
 			   (when (and comments (not (string= comments "no"))
@@ -336,107 +333,137 @@ form
     (insert
      (format
       "%s\n"
-      (replace-regexp-in-string
-       "^," ""
+      (org-unescape-code-in-string
        (org-babel-trim body (if org-src-preserve-indentation "[\f\n\r\v]")))))
     (when link-p
       (funcall
        insert-comment
        (org-fill-template org-babel-tangle-comment-format-end link-data)))))
 
-(defun org-babel-tangle-collect-blocks (&optional language)
+(defvar org-comment-string) ;; Defined in org.el
+(defun org-babel-tangle-collect-blocks (&optional language tangle-file)
   "Collect source blocks in the current Org-mode file.
 Return an association list of source-code block specifications of
 the form used by `org-babel-spec-to-string' grouped by language.
-Optional argument LANG can be used to limit the collected source
-code blocks by language."
-  (let ((block-counter 1) (current-heading "") blocks)
+Optional argument LANGUAGE can be used to limit the collected
+source code blocks by language.  Optional argument TANGLE-FILE
+can be used to limit the collected code blocks by target file."
+  (let ((block-counter 1) (current-heading "") blocks by-lang)
     (org-babel-map-src-blocks (buffer-file-name)
-      ((lambda (new-heading)
-	 (if (not (string= new-heading current-heading))
-	     (progn
-	       (setq block-counter 1)
-	       (setq current-heading new-heading))
-	   (setq block-counter (+ 1 block-counter))))
-       (replace-regexp-in-string "[ \t]" "-"
-				 (condition-case nil
-				     (or (nth 4 (org-heading-components))
-					 "(dummy for heading without text)")
-				   (error (buffer-file-name)))))
-      (let* ((start-line (save-restriction (widen)
-					   (+ 1 (line-number-at-pos (point)))))
-	     (file (buffer-file-name))
-	     (info (org-babel-get-src-block-info 'light))
-	     (src-lang (nth 0 info)))
-        (unless (string= (cdr (assoc :tangle (nth 2 info))) "no")
+      (lambda (new-heading)
+	(if (not (string= new-heading current-heading))
+	    (progn
+	      (setq block-counter 1)
+	      (setq current-heading new-heading))
+	  (setq block-counter (+ 1 block-counter))))
+      (replace-regexp-in-string "[ \t]" "-"
+				(condition-case nil
+				    (or (nth 4 (org-heading-components))
+					"(dummy for heading without text)")
+				  (error (buffer-file-name))))
+      (let* ((info (org-babel-get-src-block-info 'light))
+	     (src-lang (nth 0 info))
+	     (src-tfile (cdr (assoc :tangle (nth 2 info)))))
+        (unless (or (string-match (concat "^" org-comment-string) current-heading)
+		    (string= (cdr (assoc :tangle (nth 2 info))) "no")
+		    (and tangle-file (not (equal tangle-file src-tfile))))
           (unless (and language (not (string= language src-lang)))
-	    (let* ((info (org-babel-get-src-block-info))
-		   (params (nth 2 info))
-		   (link ((lambda (link)
-			    (and (string-match org-bracket-link-regexp link)
-				 (match-string 1 link)))
-			  (org-no-properties
-			   (org-store-link nil))))
-		   (source-name
-		    (intern (or (nth 4 info)
-				(format "%s:%d"
-					current-heading block-counter))))
-		   (expand-cmd
-		    (intern (concat "org-babel-expand-body:" src-lang)))
-		   (assignments-cmd
-		    (intern (concat "org-babel-variable-assignments:" src-lang)))
-		   (body
-		    ((lambda (body) ;; run the tangle-body-hook
-		       (with-temp-buffer
-			 (insert body)
-			 (run-hooks 'org-babel-tangle-body-hook)
-			 (buffer-string)))
-		     ((lambda (body) ;; expand the body in language specific manner
-			(if (assoc :no-expand params)
-			    body
-			  (if (fboundp expand-cmd)
-			      (funcall expand-cmd body params)
-			    (org-babel-expand-body:generic
-			     body params
-			     (and (fboundp assignments-cmd)
-				  (funcall assignments-cmd params))))))
-		      (if (org-babel-noweb-p params :tangle)
-			  (org-babel-expand-noweb-references info)
-			(nth 1 info)))))
-		   (comment
-		    (when (or (string= "both" (cdr (assoc :comments params)))
-			      (string= "org" (cdr (assoc :comments params))))
-		      ;; from the previous heading or code-block end
-		      (funcall
-		       org-babel-process-comment-text
-		       (buffer-substring
-			(max (condition-case nil
-				 (save-excursion
-				   (org-back-to-heading t)  ; sets match data
-				   (match-end 0))
-			       (error (point-min)))
-			     (save-excursion
-			       (if (re-search-backward
-				    org-babel-src-block-regexp nil t)
-				   (match-end 0)
-				 (point-min))))
-			(point)))))
-		   by-lang)
-	      ;; add the spec for this block to blocks under it's language
-	      (setq by-lang (cdr (assoc src-lang blocks)))
-	      (setq blocks (delq (assoc src-lang blocks) blocks))
-	      (setq blocks (cons
-			    (cons src-lang
-				  (cons (list start-line file link
-					      source-name params body comment)
-					by-lang)) blocks)))))))
-    ;; ensure blocks in the correct order
+	    ;; Add the spec for this block to blocks under it's language
+	    (setq by-lang (cdr (assoc src-lang blocks)))
+	    (setq blocks (delq (assoc src-lang blocks) blocks))
+	    (setq blocks (cons
+			  (cons src-lang
+				(cons
+				 (org-babel-tangle-single-block
+				  block-counter)
+				 by-lang)) blocks))))))
+    ;; Ensure blocks are in the correct order
     (setq blocks
           (mapcar
 	   (lambda (by-lang) (cons (car by-lang) (reverse (cdr by-lang))))
 	   blocks))
     blocks))
 
+(defun org-babel-tangle-single-block
+  (block-counter &optional only-this-block)
+  "Collect the tangled source for current block.
+Return the list of block attributes needed by
+`org-babel-tangle-collect-blocks'.
+When ONLY-THIS-BLOCK is non-nil, return the full association
+list to be used by `org-babel-tangle' directly."
+  (let* ((info (org-babel-get-src-block-info))
+	 (start-line
+	  (save-restriction (widen)
+			    (+ 1 (line-number-at-pos (point)))))
+	 (file (buffer-file-name))
+	 (src-lang (nth 0 info))
+	 (params (nth 2 info))
+	 (extra (nth 3 info))
+	 (cref-fmt (or (and (string-match "-l \"\\(.+\\)\"" extra)
+			    (match-string 1 extra))
+		       org-coderef-label-format))
+	 (link (let ((link (org-no-properties
+                            (org-store-link nil))))
+                 (and (string-match org-bracket-link-regexp link)
+                      (match-string 1 link))))
+	 (source-name
+	  (intern (or (nth 4 info)
+		      (format "%s:%d"
+			      (or (ignore-errors (nth 4 (org-heading-components)))
+				  "No heading")
+			      block-counter))))
+	 (expand-cmd
+	  (intern (concat "org-babel-expand-body:" src-lang)))
+	 (assignments-cmd
+	  (intern (concat "org-babel-variable-assignments:" src-lang)))
+	 (body
+	  ;; Run the tangle-body-hook.
+          (let* ((body ;; Expand the body in language specific manner.
+                  (if (org-babel-noweb-p params :tangle)
+                      (org-babel-expand-noweb-references info)
+                    (nth 1 info)))
+                 (body
+                  (if (assoc :no-expand params)
+                      body
+                    (if (fboundp expand-cmd)
+                        (funcall expand-cmd body params)
+                      (org-babel-expand-body:generic
+                       body params
+                       (and (fboundp assignments-cmd)
+                            (funcall assignments-cmd params)))))))
+            (with-temp-buffer
+              (insert body)
+              (when (string-match "-r" extra)
+                (goto-char (point-min))
+                (while (re-search-forward
+                        (replace-regexp-in-string "%s" ".+" cref-fmt) nil t)
+                  (replace-match "")))
+              (run-hooks 'org-babel-tangle-body-hook)
+              (buffer-string))))
+	 (comment
+	  (when (or (string= "both" (cdr (assoc :comments params)))
+		    (string= "org" (cdr (assoc :comments params))))
+	    ;; From the previous heading or code-block end
+	    (funcall
+	     org-babel-process-comment-text
+	     (buffer-substring
+	      (max (condition-case nil
+		       (save-excursion
+			 (org-back-to-heading t)  ; Sets match data
+			 (match-end 0))
+		     (error (point-min)))
+		   (save-excursion
+		     (if (re-search-backward
+			  org-babel-src-block-regexp nil t)
+			 (match-end 0)
+		       (point-min))))
+	      (point)))))
+	 (result
+	  (list start-line file link source-name params body comment)))
+    (if only-this-block
+	(list (cons src-lang (list result)))
+      result)))
+
 (defun org-babel-tangle-comment-links ( &optional info)
   "Return a list of begin and end link comments for the code block at point."
   (let* ((start-line (org-babel-where-is-src-block-head))
@@ -447,9 +474,8 @@ code blocks by language."
 	 (source-name (nth 4 (or info (org-babel-get-src-block-info 'light))))
 	 (link-data (mapcar (lambda (el)
 			      (cons (symbol-name el)
-				    ((lambda (le)
-				       (if (stringp le) le (format "%S" le)))
-				     (eval el))))
+				    (let ((le (eval el)))
+                                      (if (stringp le) le (format "%S" le)))))
 			    '(start-line file link source-name))))
     (list (org-fill-template org-babel-tangle-comment-format-beg link-data)
 	  (org-fill-template org-babel-tangle-comment-format-end link-data))))
@@ -481,13 +507,15 @@ which enable the original code blocks to be found."
   "Jump from a tangled code file to the related Org-mode file."
   (interactive)
   (let ((mid (point))
-	start end done
+	start body-start end done
         target-buffer target-char link path block-name body)
     (save-window-excursion
       (save-excursion
 	(while (and (re-search-backward org-bracket-link-analytic-regexp nil t)
 		    (not ; ever wider searches until matching block comments
 		     (and (setq start (point-at-eol))
+			  (setq body-start (save-excursion
+					     (forward-line 2) (point-at-bol)))
 			  (setq link (match-string 0))
 			  (setq path (match-string 3))
 			  (setq block-name (match-string 5))
@@ -508,12 +536,25 @@ which enable the original code blocks to be found."
           (org-babel-next-src-block
            (string-to-number (match-string 1 block-name)))
         (org-babel-goto-named-src-block block-name))
+      ;; position at the beginning of the code block body
+      (goto-char (org-babel-where-is-src-block-head))
+      (forward-line 1)
+      ;; Use org-edit-special to isolate the code.
+      (org-edit-special)
+      ;; Then move forward the correct number of characters in the
+      ;; code buffer.
+      (forward-char (- mid body-start))
+      ;; And return to the Org-mode buffer with the point in the right
+      ;; place.
+      (org-edit-src-exit)
       (setq target-char (point)))
-    (pop-to-buffer target-buffer)
+    (org-src-switch-to-buffer target-buffer t)
     (prog1 body (goto-char target-char))))
 
 (provide 'ob-tangle)
 
-
+;; Local variables:
+;; generated-autoload-file: "org-loaddefs.el"
+;; End:
 
 ;;; ob-tangle.el ends here