diff options
author | Bastien Guerry <bzg@altern.org> | 2012-08-10 17:44:45 +0200 |
---|---|---|
committer | Bastien Guerry <bzg@altern.org> | 2012-08-10 17:44:45 +0200 |
commit | 6c7ac786aa817b2fb61c0139d0b98d66910afdeb (patch) | |
tree | 8e755e59a6f4d1b307db7d36e1b9e5281297859f | |
parent | 57104f9fb21714d609c406e676ce3a5ab9c0fc42 (diff) | |
download | org-mode-6c7ac786aa817b2fb61c0139d0b98d66910afdeb.tar.gz |
ob.el: Don't use `org-flet'
* ob.el (org-babel-edit-distance, org-babel-sha1-hash)
(org-babel-get-rownames, org-babel-insert-result)
(org-babel-merge-params)
(org-babel-expand-noweb-references): Don't use `org-flet'.
Also indent some functions correctly.
-rw-r--r-- | lisp/ob.el | 380 |
1 files changed, 191 insertions, 189 deletions
@@ -113,9 +113,9 @@ remove code block execution from C-c C-c as further protection against accidental code block evaluation. The `org-babel-no-eval-on-ctrl-c-ctrl-c' variable can be used to remove code block execution from the C-c C-c keybinding." - :group 'org-babel - :version "24.1" - :type '(choice boolean function)) + :group 'org-babel + :version "24.1" + :type '(choice boolean function)) ;; don't allow this variable to be changed through file settings (put 'org-confirm-babel-evaluate 'safe-local-variable (lambda (x) (eq x t))) @@ -419,9 +419,9 @@ then run `org-babel-pop-to-session'." (noweb-sep . :any) (padline . ((yes no))) (results . ((file list vector table scalar verbatim) - (raw org html latex code pp wrap) - (replace silent append prepend) - (output value))) + (raw org html latex code pp wrap) + (replace silent append prepend) + (output value))) (rownames . ((no yes))) (sep . :any) (session . :any) @@ -602,7 +602,7 @@ arguments and pop open the results in a preview buffer." (params (setf (nth 2 info) (sort (org-babel-merge-params (nth 2 info) params) (lambda (el1 el2) (string< (symbol-name (car el1)) - (symbol-name (car el2))))))) + (symbol-name (car el2))))))) (body (setf (nth 1 info) (if (org-babel-noweb-p params :eval) (org-babel-expand-noweb-references info) (nth 1 info)))) @@ -625,15 +625,15 @@ arguments and pop open the results in a preview buffer." (number-sequence 1 (1+ l1))))) (in (lambda (i j) (aref (aref dist i) j))) (mmin (lambda (&rest lst) (apply #'min (remove nil lst))))) - (setf (aref (aref dist 0) 0) 0) - (dolist (i (number-sequence 1 l1)) - (dolist (j (number-sequence 1 l2)) - (setf (aref (aref dist i) j) - (+ (if (equal (aref s1 (1- i)) (aref s2 (1- j))) 0 1) - (funcall mmin (funcall in (1- i) j) - (funcall in i (1- j)) - (funcall in (1- i) (1- j))))))) - (funcall in l1 l2))) + (setf (aref (aref dist 0) 0) 0) + (dolist (i (number-sequence 1 l1)) + (dolist (j (number-sequence 1 l2)) + (setf (aref (aref dist i) j) + (+ (if (equal (aref s1 (1- i)) (aref s2 (1- j))) 0 1) + (funcall mmin (funcall in (1- i) j) + (funcall in i (1- j)) + (funcall in (1- i) (1- j))))))) + (funcall in l1 l2))) (defun org-babel-combine-header-arg-lists (original &rest others) "Combine a number of lists of header argument names and arguments." @@ -680,10 +680,10 @@ arguments and pop open the results in a preview buffer." org-babel-common-header-args-w-values (if (boundp lang-headers) (eval lang-headers) nil))) (arg (org-icompleting-read - "Header Arg: " - (mapcar - (lambda (header-spec) (symbol-name (car header-spec))) - headers)))) + "Header Arg: " + (mapcar + (lambda (header-spec) (symbol-name (car header-spec))) + headers)))) (insert ":" arg) (let ((vals (cdr (assoc (intern arg) headers)))) (when vals @@ -804,10 +804,10 @@ with a prefix argument then this is passed on to (other-window 1))) (info (org-babel-get-src-block-info)) (org-src-window-setup 'reorganize-frame)) - (save-excursion - (org-babel-switch-to-session arg info)) - (org-edit-src-code) - (funcall swap-windows))) + (save-excursion + (org-babel-switch-to-session arg info)) + (org-edit-src-code) + (funcall swap-windows))) (defmacro org-babel-do-in-edit-buffer (&rest body) "Evaluate BODY in edit buffer if there is a code block at point. @@ -1025,25 +1025,25 @@ the current subtree." (sort (copy-sequence (nth 2 info)) (lambda (a b) (string< (car a) (car b))))) (org-labels ((rm (lst) - (dolist (p '("replace" "silent" "append" "prepend")) - (setq lst (remove p lst))) - lst) - (norm (arg) - (let ((v (if (and (listp (cdr arg)) (null (cddr arg))) - (copy-sequence (cdr arg)) - (cdr arg)))) - (when (and v (not (and (sequencep v) - (not (consp v)) - (= (length v) 0)))) - (cond - ((and (listp v) ; lists are sorted - (member (car arg) '(:result-params))) - (sort (rm v) #'string<)) - ((and (stringp v) ; strings are sorted - (member (car arg) '(:results :exports))) - (mapconcat #'identity (sort (rm (split-string v)) - #'string<) " ")) - (t v)))))) + (dolist (p '("replace" "silent" "append" "prepend")) + (setq lst (remove p lst))) + lst) + (norm (arg) + (let ((v (if (and (listp (cdr arg)) (null (cddr arg))) + (copy-sequence (cdr arg)) + (cdr arg)))) + (when (and v (not (and (sequencep v) + (not (consp v)) + (= (length v) 0)))) + (cond + ((and (listp v) ; lists are sorted + (member (car arg) '(:result-params))) + (sort (rm v) #'string<)) + ((and (stringp v) ; strings are sorted + (member (car arg) '(:results :exports))) + (mapconcat #'identity (sort (rm (split-string v)) + #'string<) " ")) + (t v)))))) ((lambda (hash) (when (org-called-interactively-p 'interactive) (message hash)) hash) (let ((it (format "%s-%s" @@ -1304,11 +1304,11 @@ instances of \"[ \t]:\" set ALTS to '((32 9) . 58)." (first= (lambda (str) (= ch (aref str 0))))) (reverse (org-reduce (lambda (acc el) - (let ((head (car acc))) - (if (and head (or (funcall last= head) (funcall first= el))) - (cons (concat head el) (cdr acc)) - (cons el acc)))) - list :initial-value nil)))) + (let ((head (car acc))) + (if (and head (or (funcall last= head) (funcall first= el))) + (cons (concat head el) (cdr acc)) + (cons el acc)))) + list :initial-value nil)))) (defun org-babel-parse-header-arguments (arg-string) "Parse a string of header arguments returning an alist." @@ -1397,20 +1397,20 @@ names." Return a cons cell, the `car' of which contains the TABLE less colnames, and the `cdr' of which contains a list of the column names. Note: this function removes any hlines in TABLE." - (org-flet ((trans (table) (apply #'mapcar* #'list table))) - (let* ((width (apply 'max - (mapcar (lambda (el) (if (listp el) (length el) 0)) table))) - (table (trans (mapcar (lambda (row) - (if (not (equal row 'hline)) - row - (setq row '()) - (dotimes (n width) - (setq row (cons 'hline row))) - row)) - table)))) - (cons (mapcar (lambda (row) (if (equal (car row) 'hline) 'hline row)) - (trans (cdr table))) - (remove 'hline (car table)))))) + (let* ((trans (lambda (table) (apply #'mapcar* #'list table))) + (width (apply 'max + (mapcar (lambda (el) (if (listp el) (length el) 0)) table))) + (table (funcall trans (mapcar (lambda (row) + (if (not (equal row 'hline)) + row + (setq row '()) + (dotimes (n width) + (setq row (cons 'hline row))) + row)) + table)))) + (cons (mapcar (lambda (row) (if (equal (car row) 'hline) 'hline row)) + (funcall trans (cdr table))) + (remove 'hline (car table))))) (defun org-babel-put-colnames (table colnames) "Add COLNAMES to TABLE if they exist." @@ -1713,7 +1713,7 @@ following the source block." (beginning-of-line 1) (looking-at org-babel-lob-one-liner-regexp))) (inlinep (when (org-babel-get-inline-src-block-matches) - (match-end 0))) + (match-end 0))) (name (if on-lob-line (mapconcat #'identity (butlast (org-babel-lob-get-info)) "") (nth 4 (or info (org-babel-get-src-block-info 'light))))) @@ -1937,12 +1937,12 @@ code ---- the results are extracted in the syntax of the source ((member "prepend" result-params)))) ; already there (setq results-switches (if results-switches (concat " " results-switches) "")) - (org-flet ((wrap (start finish) - (goto-char end) (insert (concat finish "\n")) - (goto-char beg) (insert (concat start "\n")) - (goto-char end) (goto-char (point-at-eol)) - (setq end (point-marker))) - (proper-list-p (it) (and (listp it) (null (cdr (last it)))))) + (let ((wrap (lambda (start finish) + (goto-char end) (insert (concat finish "\n")) + (goto-char beg) (insert (concat start "\n")) + (goto-char end) (goto-char (point-at-eol)) + (setq end (point-marker)))) + (proper-list-p (lambda (it) (and (listp it) (null (cdr (last it))))))) ;; insert results based on type (cond ;; do nothing for an empty result @@ -1959,7 +1959,7 @@ code ---- the results are extracted in the syntax of the source '(:splicep nil :istart "- " :iend "\n"))) "\n")) ;; assume the result is a table if it's not a string - ((proper-list-p result) + ((funcall proper-list-p result) (goto-char beg) (insert (concat (orgtbl-to-orgtbl (if (or (eq 'hline (car result)) @@ -1968,33 +1968,33 @@ code ---- the results are extracted in the syntax of the source result (list result)) '(:fmt (lambda (cell) (format "%s" cell)))) "\n")) (goto-char beg) (when (org-at-table-p) (org-table-align))) - ((and (listp result) (not (proper-list-p result))) + ((and (listp result) (not (funcall proper-list-p result))) (insert (format "%s\n" result))) ((member "file" result-params) (when inlinep (goto-char inlinep)) (insert result)) (t (goto-char beg) (insert result))) - (when (proper-list-p result) (goto-char (org-table-end))) + (when (funcall proper-list-p result) (goto-char (org-table-end))) (setq end (point-marker)) ;; possibly wrap result (cond ((assoc :wrap (nth 2 info)) (let ((name (or (cdr (assoc :wrap (nth 2 info))) "RESULTS"))) - (wrap (concat "#+BEGIN_" name) (concat "#+END_" name)))) + (funcall wrap (concat "#+BEGIN_" name) (concat "#+END_" name)))) ((member "html" result-params) - (wrap "#+BEGIN_HTML" "#+END_HTML")) + (funcall wrap "#+BEGIN_HTML" "#+END_HTML")) ((member "latex" result-params) - (wrap "#+BEGIN_LaTeX" "#+END_LaTeX")) + (funcall wrap "#+BEGIN_LaTeX" "#+END_LaTeX")) ((member "code" result-params) - (wrap (format "#+BEGIN_SRC %s%s" (or lang "none") results-switches) - "#+END_SRC")) + (funcall wrap (format "#+BEGIN_SRC %s%s" (or lang "none") results-switches) + "#+END_SRC")) ((member "org" result-params) - (wrap "#+BEGIN_ORG" "#+END_ORG")) + (funcall wrap "#+BEGIN_ORG" "#+END_ORG")) ((member "raw" result-params) (goto-char beg) (if (org-at-table-p) (org-cycle))) ((member "wrap" result-params) - (wrap ":RESULTS:" ":END:")) - ((and (not (proper-list-p result)) + (funcall wrap ":RESULTS:" ":END:")) + ((and (not (funcall proper-list-p result)) (not (member "file" result-params))) (org-babel-examplize-region beg end results-switches) (setq end (point))))) @@ -2102,33 +2102,34 @@ file's directory then expand relative links." Later elements of PLISTS override the values of previous elements. This takes into account some special considerations for certain parameters when merging lists." - (let ((results-exclusive-groups - (mapcar (lambda (group) (mapcar #'symbol-name group)) - (cdr (assoc 'results org-babel-common-header-args-w-values)))) - (exports-exclusive-groups - (mapcar (lambda (group) (mapcar #'symbol-name group)) - (cdr (assoc 'exports org-babel-common-header-args-w-values)))) - (variable-index 0) - params results exports tangle noweb cache vars shebang comments padline) - (org-flet ((e-merge (exclusive-groups &rest result-params) - ;; maintain exclusivity of mutually exclusive parameters - (let (output) - (mapc (lambda (new-params) - (mapc (lambda (new-param) - (mapc (lambda (exclusive-group) - (when (member new-param exclusive-group) - (mapcar (lambda (excluded-param) - (setq output - (delete - excluded-param - output))) - exclusive-group))) - exclusive-groups) - (setq output (org-uniquify - (cons new-param output)))) - new-params)) - result-params) - output))) + (let* ((results-exclusive-groups + (mapcar (lambda (group) (mapcar #'symbol-name group)) + (cdr (assoc 'results org-babel-common-header-args-w-values)))) + (exports-exclusive-groups + (mapcar (lambda (group) (mapcar #'symbol-name group)) + (cdr (assoc 'exports org-babel-common-header-args-w-values)))) + (variable-index 0) + (e-merge (lambda (exclusive-groups &rest result-params) + ;; maintain exclusivity of mutually exclusive parameters + (let (output) + (mapc (lambda (new-params) + (mapc (lambda (new-param) + (mapc (lambda (exclusive-group) + (when (member new-param exclusive-group) + (mapcar (lambda (excluded-param) + (setq output + (delete + excluded-param + output))) + exclusive-group))) + exclusive-groups) + (setq output (org-uniquify + (cons new-param output)))) + new-params)) + result-params) + output))) + params results exports tangle noweb cache vars shebang comments padline) + (mapc (lambda (plist) (mapc @@ -2162,56 +2163,56 @@ parameters when merging lists." (error "variable \"%s\" must be assigned a default value" (cdr pair)))))) (:results - (setq results (e-merge results-exclusive-groups + (setq results (funcall e-merge results-exclusive-groups results (split-string (let ((r (cdr pair))) (if (stringp r) r (eval r))))))) (:file (when (cdr pair) - (setq results (e-merge results-exclusive-groups + (setq results (funcall e-merge results-exclusive-groups results '("file"))) (unless (or (member "both" exports) (member "none" exports) (member "code" exports)) - (setq exports (e-merge exports-exclusive-groups + (setq exports (funcall e-merge exports-exclusive-groups exports '("results")))) (setq params (cons pair (assq-delete-all (car pair) params))))) (:exports - (setq exports (e-merge exports-exclusive-groups + (setq exports (funcall e-merge exports-exclusive-groups exports (split-string (cdr pair))))) (:tangle ;; take the latest -- always overwrite (setq tangle (or (list (cdr pair)) tangle))) (:noweb - (setq noweb (e-merge + (setq noweb (funcall e-merge '(("yes" "no" "tangle" "no-export" "strip-export" "eval")) noweb (split-string (or (cdr pair) ""))))) (:cache - (setq cache (e-merge '(("yes" "no")) cache + (setq cache (funcall e-merge '(("yes" "no")) cache (split-string (or (cdr pair) ""))))) (:padline - (setq padline (e-merge '(("yes" "no")) padline + (setq padline (funcall e-merge '(("yes" "no")) padline (split-string (or (cdr pair) ""))))) (:shebang ;; take the latest -- always overwrite (setq shebang (or (list (cdr pair)) shebang))) (:comments - (setq comments (e-merge '(("yes" "no")) comments + (setq comments (funcall e-merge '(("yes" "no")) comments (split-string (or (cdr pair) ""))))) (t ;; replace: this covers e.g. :session (setq params (cons pair (assq-delete-all (car pair) params)))))) plist)) - plists)) - (setq vars (reverse vars)) - (while vars (setq params (cons (cons :var (cddr (pop vars))) params))) - (mapc - (lambda (hd) - (let ((key (intern (concat ":" (symbol-name hd)))) - (val (eval hd))) - (setf params (cons (cons key (mapconcat 'identity val " ")) params)))) - '(results exports tangle noweb padline cache shebang comments)) - params)) + plists) + (setq vars (reverse vars)) + (while vars (setq params (cons (cons :var (cddr (pop vars))) params))) + (mapc + (lambda (hd) + (let ((key (intern (concat ":" (symbol-name hd)))) + (val (eval hd))) + (setf params (cons (cons key (mapconcat 'identity val " ")) params)))) + '(results exports tangle noweb padline cache shebang comments)) + params)) (defvar *org-babel-use-quick-and-dirty-noweb-expansion* nil "Set to true to use regular expressions to expand noweb references. @@ -2228,10 +2229,10 @@ CONTEXT may be one of :tangle, :export or :eval." (car as) (intersect (cdr as) bs))))) (intersect (case context - (:tangle '("yes" "tangle" "no-export" "strip-export")) - (:eval '("yes" "no-export" "strip-export" "eval")) - (:export '("yes"))) - (split-string (or (cdr (assoc :noweb params)) ""))))) + (:tangle '("yes" "tangle" "no-export" "strip-export")) + (:eval '("yes" "no-export" "strip-export" "eval")) + (:export '("yes"))) + (split-string (or (cdr (assoc :noweb params)) ""))))) (defun org-babel-expand-noweb-references (&optional info parent-buffer) "Expand Noweb references in the body of the current source code block. @@ -2270,13 +2271,14 @@ block but are passed literally to the \"example-block\"." (comment (string= "noweb" (cdr (assoc :comments (nth 2 info))))) (rx-prefix (concat "\\(" org-babel-src-name-regexp "\\|" ":noweb-ref[ \t]+" "\\)")) - (new-body "") index source-name evaluate prefix blocks-in-buffer) - (org-flet ((nb-add (text) (setq new-body (concat new-body text))) - (c-wrap (text) + (new-body "") + (nb-add (lambda (text) (setq new-body (concat new-body text)))) + (c-wrap (lambda (text) (with-temp-buffer (funcall (intern (concat lang "-mode"))) (comment-region (point) (progn (insert text) (point))) (org-babel-trim (buffer-string))))) + index source-name evaluate prefix blocks-in-buffer) (with-temp-buffer (insert body) (goto-char (point-min)) (setq index (point)) @@ -2290,75 +2292,75 @@ block but are passed literally to the \"example-block\"." (beginning-of-line 1) (point))))) ;; add interval to new-body (removing noweb reference) (goto-char (match-beginning 0)) - (nb-add (buffer-substring index (point))) + (funcall nb-add (buffer-substring index (point))) (goto-char (match-end 0)) (setq index (point)) - (nb-add + (funcall nb-add (with-current-buffer parent-buffer (save-restriction (widen) - (mapconcat ;; interpose PREFIX between every line - #'identity - (split-string - (if evaluate - (let ((raw (org-babel-ref-resolve source-name))) - (if (stringp raw) raw (format "%S" raw))) - (or - ;; retrieve from the library of babel - (nth 2 (assoc (intern source-name) - org-babel-library-of-babel)) - ;; return the contents of headlines literally - (save-excursion - (when (org-babel-ref-goto-headline-id source-name) - (org-babel-ref-headline-body))) - ;; find the expansion of reference in this buffer - (let ((rx (concat rx-prefix source-name "[ \t\n]")) - expansion) + (mapconcat ;; interpose PREFIX between every line + #'identity + (split-string + (if evaluate + (let ((raw (org-babel-ref-resolve source-name))) + (if (stringp raw) raw (format "%S" raw))) + (or + ;; retrieve from the library of babel + (nth 2 (assoc (intern source-name) + org-babel-library-of-babel)) + ;; return the contents of headlines literally (save-excursion - (goto-char (point-min)) - (if *org-babel-use-quick-and-dirty-noweb-expansion* - (while (re-search-forward rx nil t) - (let* ((i (org-babel-get-src-block-info 'light)) - (body (org-babel-expand-noweb-references i)) - (sep (or (cdr (assoc :noweb-sep (nth 2 i))) - "\n")) - (full (if comment - ((lambda (cs) - (concat (c-wrap (car cs)) "\n" - body "\n" - (c-wrap (cadr cs)))) - (org-babel-tangle-comment-links i)) - body))) - (setq expansion (cons sep (cons full expansion))))) - (org-babel-map-src-blocks nil - (let ((i (org-babel-get-src-block-info 'light))) - (when (equal (or (cdr (assoc :noweb-ref (nth 2 i))) - (nth 4 i)) - source-name) - (let* ((body (org-babel-expand-noweb-references i)) + (when (org-babel-ref-goto-headline-id source-name) + (org-babel-ref-headline-body))) + ;; find the expansion of reference in this buffer + (let ((rx (concat rx-prefix source-name "[ \t\n]")) + expansion) + (save-excursion + (goto-char (point-min)) + (if *org-babel-use-quick-and-dirty-noweb-expansion* + (while (re-search-forward rx nil t) + (let* ((i (org-babel-get-src-block-info 'light)) + (body (org-babel-expand-noweb-references i)) (sep (or (cdr (assoc :noweb-sep (nth 2 i))) "\n")) (full (if comment ((lambda (cs) - (concat (c-wrap (car cs)) "\n" + (concat (funcall c-wrap (car cs)) "\n" body "\n" - (c-wrap (cadr cs)))) + (funcall c-wrap (cadr cs)))) (org-babel-tangle-comment-links i)) body))) - (setq expansion - (cons sep (cons full expansion))))))))) - (and expansion - (mapconcat #'identity (nreverse (cdr expansion)) ""))) - ;; possibly raise an error if named block doesn't exist - (if (member lang org-babel-noweb-error-langs) - (error "%s" (concat - (org-babel-noweb-wrap source-name) - "could not be resolved (see " - "`org-babel-noweb-error-langs')")) - ""))) - "[\n\r]") (concat "\n" prefix)))))) - (nb-add (buffer-substring index (point-max))))) - new-body)) + (setq expansion (cons sep (cons full expansion))))) + (org-babel-map-src-blocks nil + (let ((i (org-babel-get-src-block-info 'light))) + (when (equal (or (cdr (assoc :noweb-ref (nth 2 i))) + (nth 4 i)) + source-name) + (let* ((body (org-babel-expand-noweb-references i)) + (sep (or (cdr (assoc :noweb-sep (nth 2 i))) + "\n")) + (full (if comment + ((lambda (cs) + (concat (funcall c-wrap (car cs)) "\n" + body "\n" + (funcall c-wrap (cadr cs)))) + (org-babel-tangle-comment-links i)) + body))) + (setq expansion + (cons sep (cons full expansion))))))))) + (and expansion + (mapconcat #'identity (nreverse (cdr expansion)) ""))) + ;; possibly raise an error if named block doesn't exist + (if (member lang org-babel-noweb-error-langs) + (error "%s" (concat + (org-babel-noweb-wrap source-name) + "could not be resolved (see " + "`org-babel-noweb-error-langs')")) + ""))) + "[\n\r]") (concat "\n" prefix)))))) + (funcall nb-add (buffer-substring index (point-max)))) + new-body)) (defun org-babel-clean-text-properties (text) "Strip all properties from text return." @@ -2524,7 +2526,7 @@ Fixes a bug in `tramp-handle-call-process-region'." (if (file-remote-p file) (let (localname) (with-parsed-tramp-file-name file nil - localname)) + localname)) file)) (defun org-babel-process-file-name (name &optional no-quote-p) |