diff options
| author | Sébastien Delafond <sdelafond@gmail.com> | 2015-08-25 12:27:35 +0200 |
|---|---|---|
| committer | Sébastien Delafond <sdelafond@gmail.com> | 2015-08-25 12:27:35 +0200 |
| commit | 1be13d57dc8357576a8285c6dadc03db9e3ed7b0 (patch) | |
| tree | e35b32d4dbd60cb6cea09f3c0797cc8877352def /lisp | |
| parent | 4dc4918d0d667f18f3d5e3dd71e6f117ddb8af8a (diff) | |
Imported Upstream version 8.3.1
Diffstat (limited to 'lisp')
90 files changed, 22962 insertions, 16448 deletions
diff --git a/lisp/ob-C.el b/lisp/ob-C.el index 2fcec79..8d5ff2f 100644 --- a/lisp/ob-C.el +++ b/lisp/ob-C.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2010-2014 Free Software Foundation, Inc. ;; Author: Eric Schulte +;; Thierry Banel ;; Keywords: literate programming, reproducible research ;; Homepage: http://orgmode.org @@ -23,37 +24,55 @@ ;;; Commentary: -;; Org-Babel support for evaluating C code. +;; Org-Babel support for evaluating C, C++, D code. ;; ;; very limited implementation: ;; - currently only support :results output ;; - not much in the way of error feedback ;;; Code: -(eval-when-compile - (require 'cl)) (require 'ob) (require 'cc-mode) (declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) - +(declare-function org-remove-indentation "org" (code &optional n)) (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("C++" . "cpp")) +(add-to-list 'org-babel-tangle-lang-exts '("D" . "d")) (defvar org-babel-default-header-args:C '()) -(defvar org-babel-C-compiler "gcc" - "Command used to compile a C source code file into an -executable.") - -(defvar org-babel-C++-compiler "g++" - "Command used to compile a C++ source code file into an -executable.") +(defcustom org-babel-C-compiler "gcc" + "Command used to compile a C source code file into an executable. +May be either a command in the path, like gcc +or an absolute path name, like /usr/local/bin/gcc +parameter may be used, like gcc -v" + :group 'org-babel + :version "24.3" + :type 'string) + +(defcustom org-babel-C++-compiler "g++" + "Command used to compile a C++ source code file into an executable. +May be either a command in the path, like g++ +or an absolute path name, like /usr/local/bin/g++ +parameter may be used, like g++ -v" + :group 'org-babel + :version "24.3" + :type 'string) + +(defcustom org-babel-D-compiler "rdmd" + "Command used to compile and execute a D source code file. +May be either a command in the path, like rdmd +or an absolute path name, like /usr/local/bin/rdmd +parameter may be used, like rdmd --chatty" + :group 'org-babel + :version "24.3" + :type 'string) (defvar org-babel-c-variant nil - "Internal variable used to hold which type of C (e.g. C or C++) + "Internal variable used to hold which type of C (e.g. C or C++ or D) is currently being evaluated.") (defun org-babel-execute:cpp (body params) @@ -61,6 +80,11 @@ is currently being evaluated.") This function calls `org-babel-execute:C++'." (org-babel-execute:C++ body params)) +(defun org-babel-expand-body:cpp (body params) + "Expand a block of C++ code with org-babel according to it's +header arguments." + (org-babel-expand-body:C++ body params)) + (defun org-babel-execute:C++ (body params) "Execute a block of C++ code with org-babel. This function is called by `org-babel-execute-src-block'." @@ -68,81 +92,168 @@ This function is called by `org-babel-execute-src-block'." (defun org-babel-expand-body:C++ (body params) "Expand a block of C++ code with org-babel according to it's -header arguments (calls `org-babel-C-expand')." - (let ((org-babel-c-variant 'cpp)) (org-babel-C-expand body params))) +header arguments." + (let ((org-babel-c-variant 'cpp)) (org-babel-C-expand-C++ body params))) + +(defun org-babel-execute:D (body params) + "Execute a block of D code with org-babel. +This function is called by `org-babel-execute-src-block'." + (let ((org-babel-c-variant 'd)) (org-babel-C-execute body params))) + +(defun org-babel-expand-body:D (body params) + "Expand a block of D code with org-babel according to it's +header arguments." + (let ((org-babel-c-variant 'd)) (org-babel-C-expand-D body params))) (defun org-babel-execute:C (body params) "Execute a block of C code with org-babel. This function is called by `org-babel-execute-src-block'." (let ((org-babel-c-variant 'c)) (org-babel-C-execute body params))) -(defun org-babel-expand-body:c (body params) +(defun org-babel-expand-body:C (body params) "Expand a block of C code with org-babel according to it's -header arguments (calls `org-babel-C-expand')." - (let ((org-babel-c-variant 'c)) (org-babel-C-expand body params))) +header arguments." + (let ((org-babel-c-variant 'c)) (org-babel-C-expand-C body params))) (defun org-babel-C-execute (body params) "This function should only be called by `org-babel-execute:C' -or `org-babel-execute:C++'." +or `org-babel-execute:C++' or `org-babel-execute:D'." (let* ((tmp-src-file (org-babel-temp-file "C-src-" - (cond - ((equal org-babel-c-variant 'c) ".c") - ((equal org-babel-c-variant 'cpp) ".cpp")))) - (tmp-bin-file (org-babel-temp-file "C-bin-" org-babel-exeext)) - (cmdline (cdr (assoc :cmdline params))) - (flags (cdr (assoc :flags params))) - (full-body (org-babel-C-expand body params)) - (compile - (progn - (with-temp-file tmp-src-file (insert full-body)) - (org-babel-eval - (format "%s -o %s %s %s" - (cond - ((equal org-babel-c-variant 'c) org-babel-C-compiler) - ((equal org-babel-c-variant 'cpp) org-babel-C++-compiler)) - (org-babel-process-file-name tmp-bin-file) - (mapconcat 'identity - (if (listp flags) flags (list flags)) " ") - (org-babel-process-file-name tmp-src-file)) "")))) + (case org-babel-c-variant + (c ".c" ) + (cpp ".cpp") + (d ".d" )))) + (tmp-bin-file (org-babel-temp-file "C-bin-" org-babel-exeext)) ;; not used for D + (cmdline (cdr (assoc :cmdline params))) + (cmdline (if cmdline (concat " " cmdline) "")) + (flags (cdr (assoc :flags params))) + (flags (mapconcat 'identity + (if (listp flags) flags (list flags)) " ")) + (full-body + (case org-babel-c-variant + (c (org-babel-C-expand-C body params)) + (cpp (org-babel-C-expand-C++ body params)) + (d (org-babel-C-expand-D body params))))) + (with-temp-file tmp-src-file (insert full-body)) + (case org-babel-c-variant + ((c cpp) + (org-babel-eval + (format "%s -o %s %s %s" + (case org-babel-c-variant + (c org-babel-C-compiler) + (cpp org-babel-C++-compiler)) + (org-babel-process-file-name tmp-bin-file) + flags + (org-babel-process-file-name tmp-src-file)) "")) + (d nil)) ;; no separate compilation for D (let ((results - (org-babel-trim - (org-babel-eval - (concat tmp-bin-file (if cmdline (concat " " cmdline) "")) "")))) - (org-babel-reassemble-table - (org-babel-result-cond (cdr (assoc :result-params params)) - (org-babel-read results) - (let ((tmp-file (org-babel-temp-file "c-"))) - (with-temp-file tmp-file (insert results)) - (org-babel-import-elisp-from-file tmp-file))) - (org-babel-pick-name - (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) - (org-babel-pick-name - (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))) - )) - -(defun org-babel-C-expand (body params) + (org-babel-eval + (case org-babel-c-variant + ((c cpp) + (concat tmp-bin-file cmdline)) + (d + (format "%s %s %s %s" + org-babel-D-compiler + flags + (org-babel-process-file-name tmp-src-file) + cmdline))) + ""))) + (when results + (setq results (org-babel-trim (org-remove-indentation results))) + (org-babel-reassemble-table + (org-babel-result-cond (cdr (assoc :result-params params)) + (org-babel-read results t) + (let ((tmp-file (org-babel-temp-file "c-"))) + (with-temp-file tmp-file (insert results)) + (org-babel-import-elisp-from-file tmp-file))) + (org-babel-pick-name + (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))) + ))) + +(defun org-babel-C-expand-C++ (body params) + "Expand a block of C or C++ code with org-babel according to +it's header arguments." + (org-babel-C-expand-C body params)) + +(defun org-babel-C-expand-C (body params) "Expand a block of C or C++ code with org-babel according to it's header arguments." (let ((vars (mapcar #'cdr (org-babel-get-header params :var))) - (main-p (not (string= (cdr (assoc :main params)) "no"))) - (includes (or (cdr (assoc :includes params)) - (org-babel-read (org-entry-get nil "includes" t)))) - (defines (org-babel-read - (or (cdr (assoc :defines params)) - (org-babel-read (org-entry-get nil "defines" t)))))) + (colnames (cdar (org-babel-get-header params :colname-names))) + (main-p (not (string= (cdr (assoc :main params)) "no"))) + (includes (org-babel-read + (or (cdr (assoc :includes params)) + (org-entry-get nil "includes" t)) + nil)) + (defines (org-babel-read + (or (cdr (assoc :defines params)) + (org-entry-get nil "defines" t)) + nil))) + (when (stringp includes) + (setq includes (split-string includes))) + (when (stringp defines) + (let ((y nil) + (result (list t))) + (dolist (x (split-string defines)) + (if (null y) + (setq y x) + (nconc result (list (concat y " " x))) + (setq y nil))) + (setq defines (cdr result)))) (mapconcat 'identity (list ;; includes (mapconcat (lambda (inc) (format "#include %s" inc)) - (if (listp includes) includes (list includes)) "\n") + includes "\n") ;; defines (mapconcat (lambda (inc) (format "#define %s" inc)) (if (listp defines) defines (list defines)) "\n") ;; variables (mapconcat 'org-babel-C-var-to-C vars "\n") + ;; table sizes + (mapconcat 'org-babel-C-table-sizes-to-C vars "\n") + ;; tables headers utility + (when colnames + (org-babel-C-utility-header-to-C)) + ;; tables headers + (mapconcat 'org-babel-C-header-to-C colnames "\n") + ;; body + (if main-p + (org-babel-C-ensure-main-wrap body) + body) "\n") "\n"))) + +(defun org-babel-C-expand-D (body params) + "Expand a block of D code with org-babel according to +it's header arguments." + (let ((vars (mapcar #'cdr (org-babel-get-header params :var))) + (colnames (cdar (org-babel-get-header params :colname-names))) + (main-p (not (string= (cdr (assoc :main params)) "no"))) + (imports (or (cdr (assoc :imports params)) + (org-babel-read (org-entry-get nil "imports" t))))) + (when (stringp imports) + (setq imports (split-string imports))) + (setq imports (append imports '("std.stdio" "std.conv"))) + (mapconcat 'identity + (list + "module mmm;" + ;; imports + (mapconcat + (lambda (inc) (format "import %s;" inc)) + imports "\n") + ;; variables + (mapconcat 'org-babel-C-var-to-C vars "\n") + ;; table sizes + (mapconcat 'org-babel-C-table-sizes-to-C vars "\n") + ;; tables headers utility + (when colnames + (org-babel-C-utility-header-to-C)) + ;; tables headers + (mapconcat 'org-babel-C-header-to-C colnames "\n") ;; body (if main-p (org-babel-C-ensure-main-wrap body) @@ -177,58 +288,79 @@ support for sessions" "Determine the type of VAL. Return a list (TYPE-NAME FORMAT). TYPE-NAME should be the name of the type. FORMAT can be either a format string or a function which is called with VAL." + (let* ((basetype (org-babel-C-val-to-base-type val)) + (type + (case basetype + (integerp '("int" "%d")) + (floatp '("double" "%f")) + (stringp + (list + (if (equal org-babel-c-variant 'd) "string" "const char*") + "\"%s\"")) + (t (error "unknown type %S" basetype))))) + (cond + ((integerp val) type) ;; an integer declared in the #+begin_src line + ((floatp val) type) ;; a numeric declared in the #+begin_src line + ((and (listp val) (listp (car val))) ;; a table + `(,(car type) + (lambda (val) + (cons + (format "[%d][%d]" (length val) (length (car val))) + (concat + (if (equal org-babel-c-variant 'd) "[\n" "{\n") + (mapconcat + (lambda (v) + (concat + (if (equal org-babel-c-variant 'd) " [" " {") + (mapconcat (lambda (w) (format ,(cadr type) w)) v ",") + (if (equal org-babel-c-variant 'd) "]" "}"))) + val + ",\n") + (if (equal org-babel-c-variant 'd) "\n]" "\n}")))))) + ((or (listp val) (vectorp val)) ;; a list declared in the #+begin_src line + `(,(car type) + (lambda (val) + (cons + (format "[%d]" (length val)) + (concat + (if (equal org-babel-c-variant 'd) "[" "{") + (mapconcat (lambda (v) (format ,(cadr type) v)) val ",") + (if (equal org-babel-c-variant 'd) "]" "}")))))) + (t ;; treat unknown types as string + type)))) + +(defun org-babel-C-val-to-base-type (val) + "Determine the base type of VAL which may be +'integerp if all base values are integers +'floatp if all base values are either floating points or integers +'stringp otherwise." (cond - ((integerp val) '("int" "%d")) - ((floatp val) '("double" "%f")) + ((integerp val) 'integerp) + ((floatp val) 'floatp) ((or (listp val) (vectorp val)) - (lexical-let ((type (org-babel-C-val-to-C-list-type val))) - (list (car type) - (lambda (val) - (cons - (format "[%d]%s" - (length val) - (car (org-babel-C-format-val type (elt val 0)))) - (concat "{ " - (mapconcat (lambda (v) - (cdr (org-babel-C-format-val type v))) - val - ", ") - " }")))))) - (t ;; treat unknown types as string - '("char" (lambda (val) - (let ((s (format "%s" val))) ;; convert to string for unknown types - (cons (format "[%d]" (1+ (length s))) - (concat "\"" s "\"")))))))) - -(defun org-babel-C-val-to-C-list-type (val) - "Determine the C array type of a VAL." - (let (type) - (mapc - #'(lambda (i) - (let* ((tmp-type (org-babel-C-val-to-C-type i)) - (type-name (car type)) - (tmp-type-name (car tmp-type))) - (when (and type (not (string= type-name tmp-type-name))) - (if (and (member type-name '("int" "double" "int32_t")) - (member tmp-type-name '("int" "double" "int32_t"))) - (setq tmp-type '("double" "" "%f")) - (error "Only homogeneous lists are supported by C. You can not mix %s and %s" - type-name - tmp-type-name))) - (setq type tmp-type))) - val) - type)) + (let ((type nil)) + (mapc (lambda (v) + (case (org-babel-C-val-to-base-type v) + (stringp (setq type 'stringp)) + (floatp + (if (or (not type) (eq type 'integerp)) + (setq type 'floatp))) + (integerp + (unless type (setq type 'integerp))))) + val) + type)) + (t 'stringp))) (defun org-babel-C-var-to-C (pair) "Convert an elisp val into a string of C code specifying a var of the same value." ;; TODO list support (let ((var (car pair)) - (val (cdr pair))) + (val (cdr pair))) (when (symbolp val) (setq val (symbol-name val)) (when (= (length val) 1) - (setq val (string-to-char val)))) + (setq val (string-to-char val)))) (let* ((type-data (org-babel-C-val-to-C-type val)) (type (car type-data)) (formated (org-babel-C-format-val type-data val)) @@ -240,6 +372,68 @@ of the same value." suffix data)))) +(defun org-babel-C-table-sizes-to-C (pair) + "Create constants of table dimensions, if PAIR is a table." + (when (listp (cdr pair)) + (cond + ((listp (cadr pair)) ;; a table + (concat + (format "const int %s_rows = %d;" (car pair) (length (cdr pair))) + "\n" + (format "const int %s_cols = %d;" (car pair) (length (cadr pair))))) + (t ;; a list declared in the #+begin_src line + (format "const int %s_cols = %d;" (car pair) (length (cdr pair))))))) + +(defun org-babel-C-utility-header-to-C () + "Generate a utility function to convert a column name +into a column number." + (case org-babel-c-variant + ((c cpp) + "int get_column_num (int nbcols, const char** header, const char* column) +{ + int c; + for (c=0; c<nbcols; c++) + if (strcmp(header[c],column)==0) + return c; + return -1; +} +" + ) + (d + "int get_column_num (string[] header, string column) +{ + foreach (c, h; header) + if (h==column) + return to!int(c); + return -1; +} +" + ))) + +(defun org-babel-C-header-to-C (head) + "Convert an elisp list of header table into a C or D vector +specifying a variable with the name of the table." + (let ((table (car head)) + (headers (cdr head))) + (concat + (format + (case org-babel-c-variant + ((c cpp) "const char* %s_header[%d] = {%s};") + (d "string %s_header[%d] = [%s];")) + table + (length headers) + (mapconcat (lambda (h) (format "%S" h)) headers ",")) + "\n" + (case org-babel-c-variant + ((c cpp) + (format + "const char* %s_h (int row, const char* col) { return %s[row][get_column_num(%d,%s_header,col)]; }" + table table (length headers) table)) + (d + (format + "string %s_h (ulong row, string col) { return %s[row][get_column_num(%s_header,col)]; }" + table table table)))))) + (provide 'ob-C) ;;; ob-C.el ends here diff --git a/lisp/ob-J.el b/lisp/ob-J.el new file mode 100644 index 0000000..500ce9e --- /dev/null +++ b/lisp/ob-J.el @@ -0,0 +1,179 @@ +;;; ob-J.el --- org-babel functions for J evaluation + +;; Copyright (C) 2011-2013 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating J code. +;; +;; Session interaction depends on `j-console' from package `j-mode' +;; (available in MELPA). + +;;; Code: +(require 'ob) + +(declare-function org-trim "org" (S)) +(declare-function j-console-ensure-session "ext:j-console" ()) + +(defun org-babel-expand-body:J (body params &optional processed-params) + "Expand BODY according to PARAMS, return the expanded body. +PROCESSED-PARAMS isn't used yet." + (org-babel-J-interleave-echos-except-functions body)) + +(defun org-babel-J-interleave-echos (body) + "Interleave echo',' between each source line of BODY." + (mapconcat #'identity (split-string body "\n") "\necho','\n")) + +(defun org-babel-J-interleave-echos-except-functions (body) + "Interleave echo',' between source lines of BODY that aren't functions." + (if (obj-string-match-m "\\(?:^\\|\n\\)[^\n]*\\(?:0\\|1\\|2\\|3\\|4\\|dyad\\) : 0\n.*\n)\\(?:\n\\|$\\)" body) + (let ((s1 (substring body 0 (match-beginning 0))) + (s2 (match-string 0 body)) + (s3 (substring body (match-end 0)))) + (concat + (if (string= s1 "") + "" + (concat (org-babel-J-interleave-echos s1) + "\necho','\n")) + s2 + "\necho','\n" + (org-babel-J-interleave-echos-except-functions s3))) + (org-babel-J-interleave-echos body))) + +(defun org-babel-execute:J (body params) + "Execute a block of J code BODY. +PARAMS are given by org-babel. +This function is called by `org-babel-execute-src-block'" + (message "executing J source code block") + (let* ((processed-params (org-babel-process-params params)) + (sessionp (cdr (assoc :session params))) + (session (org-babel-j-initiate-session sessionp)) + (vars (nth 2 processed-params)) + (result-params (nth 3 processed-params)) + (result-type (nth 4 processed-params)) + (full-body (org-babel-expand-body:J + body params processed-params)) + (tmp-script-file (org-babel-temp-file "J-src"))) + (org-babel-J-strip-whitespace + (if (string= sessionp "none") + (progn + (with-temp-file tmp-script-file + (insert full-body)) + (org-babel-eval (format "jconsole < %s" tmp-script-file) "")) + (org-babel-J-eval-string full-body))))) + +(defun org-babel-J-eval-string (str) + "Sends STR to the `j-console-cmd' session and exectues it." + (let ((session (j-console-ensure-session))) + (with-current-buffer (process-buffer session) + (goto-char (point-max)) + (insert (format "\n%s\n" str)) + (let ((beg (point))) + (comint-send-input) + (sit-for .1) + (buffer-substring-no-properties + beg (point-max)))))) + +(defun org-babel-J-strip-whitespace (str) + "Remove whitespace from jconsole output STR." + (mapconcat + #'identity + (delete "" (mapcar + #'org-babel-J-print-block + (split-string str "^ *,\n" t))) + "\n\n")) + +(defun obj-get-string-alignment (str) + "Return a number to describe STR alignment. +STR represents a table. +Positive/negative/zero result means right/left/undetermined. +Don't trust first line." + (let* ((str (org-trim str)) + (lines (split-string str "\n" t)) + n1 n2) + (cond ((<= (length lines) 1) + 0) + ((= (length lines) 2) + ;; numbers are right-aligned + (if (and + (numberp (read (car lines))) + (numberp (read (cadr lines))) + (setq n1 (obj-match-second-space-right (nth 0 lines))) + (setq n2 (obj-match-second-space-right (nth 1 lines)))) + n2 + 0)) + ((not (obj-match-second-space-left (nth 0 lines))) + 0) + ((and + (setq n1 (obj-match-second-space-left (nth 1 lines))) + (setq n2 (obj-match-second-space-left (nth 2 lines))) + (= n1 n2)) + n1) + ((and + (setq n1 (obj-match-second-space-right (nth 1 lines))) + (setq n2 (obj-match-second-space-right (nth 2 lines))) + (= n1 n2)) + (- n1)) + (t 0)))) + +(defun org-babel-J-print-block (x) + "Prettify jconsole output X." + (let* ((x (org-trim x)) + (a (obj-get-string-alignment x)) + (lines (split-string x "\n" t)) + b) + (cond ((< a 0) + (setq b (obj-match-second-space-right (nth 0 lines))) + (concat (make-string (+ a b) ? ) x)) + ((> a 0) + (setq b (obj-match-second-space-left (nth 0 lines))) + (concat (make-string (- a b) ? ) x)) + (t x)))) + +(defun obj-match-second-space-left (s) + "Return position of leftmost space in second space block of S or nil." + (and (string-match "^ *[^ ]+\\( \\)" s) + (match-beginning 1))) + +(defun obj-match-second-space-right (s) + "Return position of rightmost space in second space block of S or nil." + (and (string-match "^ *[^ ]+ *\\( \\)[^ ]" s) + (match-beginning 1))) + +(defun obj-string-match-m (regexp string &optional start) + "Call (string-match REGEXP STRING START). +REGEXP is modified so that .* matches newlines as well." + (string-match + (replace-regexp-in-string "\\.\\*" "[\0-\377[:nonascii:]]*" regexp) + string + start)) + +(defun org-babel-j-initiate-session (&optional session) + "Initiate a J session. +SESSION is a parameter given by org-babel." + (unless (string= session "none") + (require 'j-console) + (j-console-ensure-session))) + +(provide 'ob-J) + +;;; ob-J.el ends here diff --git a/lisp/ob-R.el b/lisp/ob-R.el index b97fd91..ac84d7d 100644 --- a/lisp/ob-R.el +++ b/lisp/ob-R.el @@ -1,6 +1,6 @@ ;;; ob-R.el --- org-babel functions for R code evaluation -;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Author: Eric Schulte ;; Dan Davison @@ -35,8 +35,11 @@ (declare-function inferior-ess-send-input "ext:ess-inf" ()) (declare-function ess-make-buffer-current "ext:ess-inf" ()) (declare-function ess-eval-buffer "ext:ess-inf" (vis)) +(declare-function ess-wait-for-process "ext:ess-inf" + (proc &optional sec-prompt wait force-redisplay)) (declare-function org-number-sequence "org-compat" (from &optional to inc)) (declare-function org-remove-if-not "org" (predicate seq)) +(declare-function org-every "org" (pred seq)) (defconst org-babel-header-args:R '((width . :any) @@ -60,12 +63,25 @@ (useDingbats . :any) (horizontal . :any) (results . ((file list vector table scalar verbatim) - (raw org html latex code pp wrap) - (replace silent append prepend) + (raw html latex org code pp drawer) + (replace silent none append prepend) (output value graphics)))) "R-specific header arguments.") +(defconst ob-R-safe-header-args + (append org-babel-safe-header-args + '(:width :height :bg :units :pointsize :antialias :quality + :compression :res :type :family :title :fonts + :version :paper :encoding :pagecentre :colormodel + :useDingbats :horizontal)) + "Header args which are safe for R babel blocks. + +See `org-babel-safe-header-args' for documentation of the format of +this variable.") + (defvar org-babel-default-header-args:R '()) +(put 'org-babel-default-header-args:R 'safe-local-variable + (org-babel-header-args-safe-fn ob-R-safe-header-args)) (defcustom org-babel-R-command "R --slave --no-save" "Name of command to use for executing R code." @@ -73,34 +89,67 @@ :version "24.1" :type 'string) -(defvar ess-local-process-name) ; dynamically scoped +(defvar ess-current-process-name) ; dynamically scoped +(defvar ess-local-process-name) ; dynamically scoped (defun org-babel-edit-prep:R (info) (let ((session (cdr (assoc :session (nth 2 info))))) (when (and session (string-match "^\\*\\(.+?\\)\\*$" session)) (save-match-data (org-babel-R-initiate-session session nil))))) +;; The usage of utils::read.table() ensures that the command +;; read.table() can be found even in circumstances when the utils +;; package is not in the search path from R. +(defconst ob-R-transfer-variable-table-with-header + "%s <- local({ + con <- textConnection( + %S + ) + res <- utils::read.table( + con, + header = %s, + row.names = %s, + sep = \"\\t\", + as.is = TRUE + ) + close(con) + res + })" + "R code used to transfer a table defined as a variable from org to R. + +This function is used when the table contains a header.") + +(defconst ob-R-transfer-variable-table-without-header + "%s <- local({ + con <- textConnection( + %S + ) + res <- utils::read.table( + con, + header = %s, + row.names = %s, + sep = \"\\t\", + as.is = TRUE, + fill = TRUE, + col.names = paste(\"V\", seq_len(%d), sep =\"\") + ) + close(con) + res + })" + "R code used to transfer a table defined as a variable from org to R. + +This function is used when the table does not contain a header.") + (defun org-babel-expand-body:R (body params &optional graphics-file) "Expand BODY according to PARAMS, return the expanded body." - (let ((graphics-file - (or graphics-file (org-babel-R-graphical-output-file params)))) - (mapconcat - #'identity - (let ((inside - (append - (when (cdr (assoc :prologue params)) - (list (cdr (assoc :prologue params)))) - (org-babel-variable-assignments:R params) - (list body) - (when (cdr (assoc :epilogue params)) - (list (cdr (assoc :epilogue params))))))) - (if graphics-file - (append - (list (org-babel-R-construct-graphics-device-call - graphics-file params)) - inside - (list "dev.off()")) - inside)) - "\n"))) + (mapconcat 'identity + (append + (when (cdr (assoc :prologue params)) + (list (cdr (assoc :prologue params)))) + (org-babel-variable-assignments:R params) + (list body) + (when (cdr (assoc :epilogue params)) + (list (cdr (assoc :epilogue params))))) + "\n")) (defun org-babel-execute:R (body params) "Execute a block of R code. @@ -112,8 +161,20 @@ This function is called by `org-babel-execute-src-block'." (cdr (assoc :session params)) params)) (colnames-p (cdr (assoc :colnames params))) (rownames-p (cdr (assoc :rownames params))) - (graphics-file (org-babel-R-graphical-output-file params)) - (full-body (org-babel-expand-body:R body params graphics-file)) + (graphics-file (and (member "graphics" (assq :result-params params)) + (org-babel-graphical-output-file params))) + (full-body + (let ((inside + (list (org-babel-expand-body:R body params graphics-file)))) + (mapconcat 'identity + (if graphics-file + (append + (list (org-babel-R-construct-graphics-device-call + graphics-file params)) + inside + (list "},error=function(e){plot(x=-1:1, y=-1:1, type='n', xlab='', ylab='', axes=FALSE); text(x=0, y=0, labels=e$message, col='red'); paste('ERROR', e$message, sep=' : ')}); dev.off()")) + inside) + "\n"))) (result (org-babel-R-evaluate session full-body result-type result-params @@ -148,7 +209,7 @@ This function is called by `org-babel-execute-src-block'." (defun org-babel-variable-assignments:R (params) "Return list of R statements assigning the block's variables." - (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (let ((vars (mapcar 'cdr (org-babel-get-header params :var)))) (mapcar (lambda (pair) (org-babel-R-assign-elisp @@ -175,33 +236,23 @@ This function is called by `org-babel-execute-src-block'." (if (listp value) (let* ((lengths (mapcar 'length (org-remove-if-not 'sequencep value))) (max (if lengths (apply 'max lengths) 0)) - (min (if lengths (apply 'min lengths) 0)) - (transition-file (org-babel-temp-file "R-import-"))) + (min (if lengths (apply 'min lengths) 0))) ;; Ensure VALUE has an orgtbl structure (depth of at least 2). (unless (listp (car value)) (setq value (list value))) - (with-temp-file transition-file - (insert - (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field)) - "\n")) - (let ((file (org-babel-process-file-name transition-file 'noquote)) + (let ((file (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field))) (header (if (or (eq (nth 1 value) 'hline) colnames-p) "TRUE" "FALSE")) (row-names (if rownames-p "1" "NULL"))) (if (= max min) - (format "%s <- read.table(\"%s\", - header=%s, - row.names=%s, - sep=\"\\t\", - as.is=TRUE)" name file header row-names) - (format "%s <- read.table(\"%s\", - header=%s, - row.names=%s, - sep=\"\\t\", - as.is=TRUE, - fill=TRUE, - col.names = paste(\"V\", seq_len(%d), sep =\"\"))" + (format ob-R-transfer-variable-table-with-header + name file header row-names) + (format ob-R-transfer-variable-table-without-header name file header row-names max)))) - (format "%s <- %s" name (org-babel-R-quote-tsv-field value)))) + (cond ((integerp value) (format "%s <- %s" name (concat (number-to-string value) "L"))) + ((floatp value) (format "%s <- %s" name value)) + ((stringp value) (format "%s <- %S" name (org-no-properties value))) + (t (format "%s <- %S" name (prin1-to-string value)))))) + (defvar ess-ask-for-ess-directory) ; dynamically scoped (defun org-babel-R-initiate-session (session params) @@ -209,7 +260,8 @@ This function is called by `org-babel-execute-src-block'." (unless (string= session "none") (let ((session (or session "*R*")) (ess-ask-for-ess-directory - (and (and (boundp 'ess-ask-for-ess-directory) ess-ask-for-ess-directory) + (and (boundp 'ess-ask-for-ess-directory) + ess-ask-for-ess-directory (not (cdr (assoc :dir params)))))) (if (org-babel-comint-buffer-livep session) session @@ -218,6 +270,10 @@ This function is called by `org-babel-execute-src-block'." ;; Session buffer exists, but with dead process (set-buffer session)) (require 'ess) (R) + (let ((R-proc (get-process (or ess-local-process-name + ess-current-process-name)))) + (while (process-get R-proc 'callbacks) + (ess-wait-for-process R-proc))) (rename-buffer (if (bufferp session) (buffer-name session) @@ -234,11 +290,6 @@ current code buffer." (process-name (get-buffer-process session))) (ess-make-buffer-current)) -(defun org-babel-R-graphical-output-file (params) - "Name of file to which R should send graphical output." - (and (member "graphics" (cdr (assq :result-params params))) - (cdr (assq :file params)))) - (defvar org-babel-R-graphics-devices '((:bmp "bmp" "filename") (:jpg "jpeg" "filename") @@ -280,14 +331,43 @@ Each member of this list is a list with three members: (substring (symbol-name (car pair)) 1) (cdr pair)) "")) params "")) - (format "%s(%s=\"%s\"%s%s%s)" + (format "%s(%s=\"%s\"%s%s%s); tryCatch({" device filearg out-file args (if extra-args "," "") (or extra-args "")))) -(defvar org-babel-R-eoe-indicator "'org_babel_R_eoe'") -(defvar org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"") - -(defvar org-babel-R-write-object-command "{function(object,transfer.file){object;invisible(if(inherits(try({tfile<-tempfile();write.table(object,file=tfile,sep=\"\\t\",na=\"nil\",row.names=%s,col.names=%s,quote=FALSE);file.rename(tfile,transfer.file)},silent=TRUE),\"try-error\")){if(!file.exists(transfer.file))file.create(transfer.file)})}}(object=%s,transfer.file=\"%s\")") +(defconst org-babel-R-eoe-indicator "'org_babel_R_eoe'") +(defconst org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"") + +(defconst org-babel-R-write-object-command "{ + function(object,transfer.file) { + object + invisible( + if ( + inherits( + try( + { + tfile<-tempfile() + write.table(object, file=tfile, sep=\"\\t\", + na=\"nil\",row.names=%s,col.names=%s, + quote=FALSE) + file.rename(tfile,transfer.file) + }, + silent=TRUE), + \"try-error\")) + { + if(!file.exists(transfer.file)) + file.create(transfer.file) + } + ) + } +}(object=%s,transfer.file=\"%s\")" + "A template for an R command to evaluate a block of code and write the result to a file. + +Has four %s escapes to be filled in: +1. Row names, \"TRUE\" or \"FALSE\" +2. Column names, \"TRUE\" or \"FALSE\" +3. The code to be run (must be an expression, not a statement) +4. The name of the file to write to") (defun org-babel-R-evaluate (session body result-type result-params column-names-p row-names-p) @@ -358,7 +438,7 @@ last statement in BODY, as elisp." column-names-p))) (output (mapconcat - #'org-babel-chomp + 'org-babel-chomp (butlast (delq nil (mapcar @@ -370,7 +450,7 @@ last statement in BODY, as elisp." (substring line (match-end 1)) line)) (org-babel-comint-with-output (session org-babel-R-eoe-output) - (insert (mapconcat #'org-babel-chomp + (insert (mapconcat 'org-babel-chomp (list body org-babel-R-eoe-indicator) "\n")) (inferior-ess-send-input)))))) "\n")))) diff --git a/lisp/ob-abc.el b/lisp/ob-abc.el new file mode 100644 index 0000000..a980b02 --- /dev/null +++ b/lisp/ob-abc.el @@ -0,0 +1,94 @@ +;;; ob-abc.el --- org-babel functions for template evaluation + +;; Copyright (C) Free Software Foundation + +;; Author: William Waites +;; Keywords: literate programming, music +;; Homepage: http://www.tardis.ed.ac.uk/wwaites +;; Version: 0.01 + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; This file adds support to Org Babel for music in ABC notation. +;;; It requires that the abcm2ps program is installed. +;;; See http://moinejf.free.fr/ + +(require 'ob) + +;; optionally define a file extension for this language +(add-to-list 'org-babel-tangle-lang-exts '("abc" . "abc")) + +;; optionally declare default header arguments for this language +(defvar org-babel-default-header-args:abc + '((:results . "file") (:exports . "results")) + "Default arguments to use when evaluating an ABC source block.") + +(defun org-babel-expand-body:abc (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (mapc + (lambda (pair) + (let ((name (symbol-name (car pair))) + (value (cdr pair))) + (setq body + (replace-regexp-in-string + (concat "\$" (regexp-quote name)) + (if (stringp value) value (format "%S" value)) + body)))) + vars) + body)) + +(defun org-babel-execute:abc (body params) + "Execute a block of ABC code with org-babel. This function is + called by `org-babel-execute-src-block'" + (message "executing Abc source code block") + (let* ((result-params (split-string (or (cdr (assoc :results params))))) + (cmdline (cdr (assoc :cmdline params))) + (out-file ((lambda (el) + (or el + (error "abc code block requires :file header argument"))) + (replace-regexp-in-string "\.pdf$" ".ps" (cdr (assoc :file params))))) + (in-file (org-babel-temp-file "abc-")) + (render (concat "abcm2ps" " " cmdline + " -O " (org-babel-process-file-name out-file) + " " (org-babel-process-file-name in-file)))) + (with-temp-file in-file (insert (org-babel-expand-body:abc body params))) + (org-babel-eval render "") + ;;; handle where abcm2ps changes the file name (to support multiple files + (when (or (string= (file-name-extension out-file) "eps") + (string= (file-name-extension out-file) "svg")) + (rename-file (concat + (file-name-sans-extension out-file) "001." + (file-name-extension out-file)) + out-file t)) + ;;; if we were asked for a pdf... + (when (string= (file-name-extension (cdr (assoc :file params))) "pdf") + (org-babel-eval (concat "ps2pdf" " " out-file " " (cdr (assoc :file params))) "")) + ;;; indicate that the file has been written + nil)) + +;; This function should be used to assign any variables in params in +;; the context of the session environment. +(defun org-babel-prep-session:abc (session params) + "Return an error because abc does not support sessions." + (error "ABC does not support sessions")) + +(provide 'ob-abc) +;;; ob-abc.el ends here diff --git a/lisp/ob-asymptote.el b/lisp/ob-asymptote.el index 21c0a17..ca58ecb 100644 --- a/lisp/ob-asymptote.el +++ b/lisp/ob-asymptote.el @@ -1,6 +1,6 @@ ;;; ob-asymptote.el --- org-babel functions for asymptote evaluation -;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Author: Eric Schulte ;; Keywords: literate programming, reproducible research @@ -45,9 +45,6 @@ (require 'ob) (eval-when-compile (require 'cl)) -(declare-function orgtbl-to-generic "org-table" (table params)) -(declare-function org-combine-plists "org" (&rest plists)) - (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("asymptote" . "asy")) diff --git a/lisp/ob-awk.el b/lisp/ob-awk.el index ed98afd..a96ba1a 100644 --- a/lisp/ob-awk.el +++ b/lisp/ob-awk.el @@ -46,9 +46,6 @@ (defun org-babel-expand-body:awk (body params) "Expand BODY according to PARAMS, return the expanded body." - (dolist (pair (mapcar #'cdr (org-babel-get-header params :var))) - (setf body (replace-regexp-in-string - (regexp-quote (format "$%s" (car pair))) (cdr pair) body))) body) (defun org-babel-execute:awk (body params) @@ -68,10 +65,17 @@ called by `org-babel-execute-src-block'" (with-temp-file tmp (insert (org-babel-awk-var-to-awk res))) tmp)))) - (cmd (mapconcat #'identity (remove nil (list org-babel-awk-command - "-f" code-file - cmd-line - in-file)) + (cmd (mapconcat #'identity + (append + (list org-babel-awk-command + "-f" code-file cmd-line) + (mapcar (lambda (pair) + (format "-v %s='%s'" + (cadr pair) + (org-babel-awk-var-to-awk + (cddr pair)))) + (org-babel-get-header params :var)) + (list in-file)) " "))) (org-babel-reassemble-table (let ((results @@ -101,11 +105,6 @@ called by `org-babel-execute-src-block'" (mapconcat echo-var var "\n")) (t (funcall echo-var var))))) -(defun org-babel-awk-table-or-string (results) - "If the results look like a table, then convert them into an -Emacs-lisp table, otherwise return the results as a string." - (org-babel-script-escape results)) - (provide 'ob-awk) diff --git a/lisp/ob-clojure.el b/lisp/ob-clojure.el index 78f3c6d..21a3ef8 100644 --- a/lisp/ob-clojure.el +++ b/lisp/ob-clojure.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2009-2014 Free Software Foundation, Inc. -;; Author: Joel Boehland -;; Eric Schulte +;; Author: Joel Boehland, Eric Schulte, Oleh Krehel +;; ;; Keywords: literate programming, reproducible research ;; Homepage: http://orgmode.org @@ -24,21 +24,27 @@ ;;; Commentary: -;; Support for evaluating clojure code, relies on slime for all eval. +;; Support for evaluating clojure code -;;; Requirements: +;; Requirements: ;; - clojure (at least 1.2.0) ;; - clojure-mode -;; - slime +;; - either cider or SLIME -;; By far, the best way to install these components is by following +;; For Cider, see https://github.com/clojure-emacs/cider + +;; For SLIME, the best way to install these components is by following ;; the directions as set out by Phil Hagelberg (Technomancy) on the ;; web page: http://technomancy.us/126 ;;; Code: (require 'ob) +(eval-when-compile + (require 'cl)) +(declare-function nrepl-dict-get "ext:nrepl-client" (dict key)) +(declare-function nrepl-sync-request:eval "ext:nrepl-client" (input &optional ns session)) (declare-function slime-eval "ext:slime" (sexp &optional package)) (defvar org-babel-tangle-lang-exts) @@ -47,6 +53,15 @@ (defvar org-babel-default-header-args:clojure '()) (defvar org-babel-header-args:clojure '((package . :any))) +(defcustom org-babel-clojure-backend + (cond ((featurep 'cider) 'cider) + (t 'slime)) + "Backend used to evaluate Clojure code blocks." + :group 'org-babel + :type '(choice + (const :tag "cider" cider) + (const :tag "SLIME" slime))) + (defun org-babel-expand-body:clojure (body params) "Expand BODY according to PARAMS, return the expanded body." (let* ((vars (mapcar #'cdr (org-babel-get-header params :var))) @@ -61,35 +76,40 @@ vars "\n ") "]\n" body ")") body)))) - (cond ((or (member "code" result-params) (member "pp" result-params)) - (format (concat "(let [org-mode-print-catcher (java.io.StringWriter.)] " - "(clojure.pprint/with-pprint-dispatch clojure.pprint/%s-dispatch " - "(clojure.pprint/pprint (do %s) org-mode-print-catcher) " - "(str org-mode-print-catcher)))") - (if (member "code" result-params) "code" "simple") body)) - ;; if (:results output), collect printed output - ((member "output" result-params) - (format "(clojure.core/with-out-str %s)" body)) - (t body)))) + (if (or (member "code" result-params) + (member "pp" result-params)) + (format "(clojure.pprint/pprint (do %s))" body) + body))) (defun org-babel-execute:clojure (body params) "Execute a block of Clojure code with Babel." - (require 'slime) - (with-temp-buffer - (insert (org-babel-expand-body:clojure body params)) - (let ((result - (slime-eval - `(swank:eval-and-grab-output - ,(buffer-substring-no-properties (point-min) (point-max))) - (cdr (assoc :package params))))) - (let ((result-params (cdr (assoc :result-params params)))) - (org-babel-result-cond result-params - result - (condition-case nil (org-babel-script-escape result) - (error result))))))) + (let ((expanded (org-babel-expand-body:clojure body params)) + result) + (case org-babel-clojure-backend + (cider + (require 'cider) + (let ((result-params (cdr (assoc :result-params params)))) + (setq result + (nrepl-dict-get + (nrepl-sync-request:eval expanded) + (if (or (member "output" result-params) + (member "pp" result-params)) + "out" + "value"))))) + (slime + (require 'slime) + (with-temp-buffer + (insert expanded) + (setq result + (slime-eval + `(swank:eval-and-grab-output + ,(buffer-substring-no-properties (point-min) (point-max))) + (cdr (assoc :package params))))))) + (org-babel-result-cond (cdr (assoc :result-params params)) + result + (condition-case nil (org-babel-script-escape result) + (error result))))) (provide 'ob-clojure) - - ;;; ob-clojure.el ends here diff --git a/lisp/ob-comint.el b/lisp/ob-comint.el index 40bfaf7..7c768d3 100644 --- a/lisp/ob-comint.el +++ b/lisp/ob-comint.el @@ -48,12 +48,13 @@ BUFFER is checked with `org-babel-comint-buffer-livep'. BODY is executed inside the protection of `save-excursion' and `save-match-data'." (declare (indent 1)) - `(save-excursion + `(progn + (unless (org-babel-comint-buffer-livep ,buffer) + (error "Buffer %s does not exist or has no process" ,buffer)) (save-match-data - (unless (org-babel-comint-buffer-livep ,buffer) - (error "Buffer %s does not exist or has no process" ,buffer)) - (set-buffer ,buffer) - ,@body))) + (with-current-buffer ,buffer + (let ((comint-input-filter (lambda (input) nil))) + ,@body))))) (def-edebug-spec org-babel-comint-in-buffer (form body)) (defmacro org-babel-comint-with-output (meta &rest body) @@ -69,46 +70,42 @@ elements are optional. This macro ensures that the filter is removed in case of an error or user `keyboard-quit' during execution of body." (declare (indent 1)) - (let ((buffer (car meta)) - (eoe-indicator (cadr meta)) - (remove-echo (cadr (cdr meta))) - (full-body (cadr (cdr (cdr meta))))) + (let ((buffer (nth 0 meta)) + (eoe-indicator (nth 1 meta)) + (remove-echo (nth 2 meta)) + (full-body (nth 3 meta))) `(org-babel-comint-in-buffer ,buffer - (let ((string-buffer "") dangling-text raw) - ;; setup filter - (setq comint-output-filter-functions + (let* ((string-buffer "") + (comint-output-filter-functions (cons (lambda (text) (setq string-buffer (concat string-buffer text))) comint-output-filter-functions)) - (unwind-protect - (progn - ;; got located, and save dangling text - (goto-char (process-mark (get-buffer-process (current-buffer)))) - (let ((start (point)) - (end (point-max))) - (setq dangling-text (buffer-substring start end)) - (delete-region start end)) - ;; pass FULL-BODY to process - ,@body - ;; wait for end-of-evaluation indicator - (while (progn - (goto-char comint-last-input-end) - (not (save-excursion - (and (re-search-forward - (regexp-quote ,eoe-indicator) nil t) - (re-search-forward - comint-prompt-regexp nil t))))) - (accept-process-output (get-buffer-process (current-buffer))) - ;; thought the following this would allow async - ;; background running, but I was wrong... - ;; (run-with-timer .5 .5 'accept-process-output - ;; (get-buffer-process (current-buffer))) - ) - ;; replace cut dangling text - (goto-char (process-mark (get-buffer-process (current-buffer)))) - (insert dangling-text)) - ;; remove filter - (setq comint-output-filter-functions - (cdr comint-output-filter-functions))) + dangling-text raw) + ;; got located, and save dangling text + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (let ((start (point)) + (end (point-max))) + (setq dangling-text (buffer-substring start end)) + (delete-region start end)) + ;; pass FULL-BODY to process + ,@body + ;; wait for end-of-evaluation indicator + (while (progn + (goto-char comint-last-input-end) + (not (save-excursion + (and (re-search-forward + (regexp-quote ,eoe-indicator) nil t) + (re-search-forward + comint-prompt-regexp nil t))))) + (accept-process-output (get-buffer-process (current-buffer))) + ;; thought the following this would allow async + ;; background running, but I was wrong... + ;; (run-with-timer .5 .5 'accept-process-output + ;; (get-buffer-process (current-buffer))) + ) + ;; replace cut dangling text + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (insert dangling-text) + ;; remove echo'd FULL-BODY from input (if (and ,remove-echo ,full-body (string-match @@ -151,7 +148,7 @@ FILE exists at end of evaluation." (if (file-exists-p file) (delete-file file)) (process-send-string (get-buffer-process buffer) - (if (string-match "\n$" string) string (concat string "\n"))) + (if (= (aref string (1- (length string))) ?\n) string (concat string "\n"))) ;; From Tramp 2.1.19 the following cache flush is not necessary (if (file-remote-p default-directory) (let (v) diff --git a/lisp/ob-coq.el b/lisp/ob-coq.el new file mode 100644 index 0000000..b6ebcff --- /dev/null +++ b/lisp/ob-coq.el @@ -0,0 +1,77 @@ +;;; ob-coq.el --- org-babel functions for Coq + +;; Copyright (C) 2010-2014 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Rudimentary support for evaluating Coq code blocks. Currently only +;; session evaluation is supported. Requires both coq.el and +;; coq-inferior.el, both of which are distributed with Coq. +;; +;; http://coq.inria.fr/ + +;;; Code: +(require 'ob) + +(declare-function run-coq "ext:coq-inferior.el" (cmd)) +(declare-function coq-proc "ext:coq-inferior.el" ()) + +(defvar org-babel-coq-buffer "*coq*" + "Buffer in which to evaluate coq code blocks.") + +(defvar org-babel-coq-eoe "org-babel-coq-eoe") + +(defun org-babel-coq-clean-prompt (string) + (if (string-match "^[^[:space:]]+ < " string) + (substring string 0 (match-beginning 0)) + string)) + +(defun org-babel-execute:coq (body params) + (let ((full-body (org-babel-expand-body:generic body params)) + (session (org-babel-coq-initiate-session)) + (pt (lambda () + (marker-position + (process-mark (get-buffer-process (current-buffer))))))) + (org-babel-coq-clean-prompt + (org-babel-comint-in-buffer session + (let ((start (funcall pt))) + (with-temp-buffer + (insert full-body) + (comint-send-region (coq-proc) (point-min) (point-max)) + (comint-send-string (coq-proc) + (if (string= (buffer-substring (- (point-max) 1) (point-max)) ".") + "\n" + ".\n"))) + (while (equal start (funcall pt)) (sleep-for 0.1)) + (buffer-substring start (funcall pt))))))) + +(defun org-babel-coq-initiate-session () + "Initiate a coq session. +If there is not a current inferior-process-buffer in SESSION then +create one. Return the initialized session." + (unless (fboundp 'run-coq) + (error "`run-coq' not defined, load coq-inferior.el")) + (save-window-excursion (run-coq "coqtop")) + (sit-for 0.1) + (get-buffer org-babel-coq-buffer)) + +(provide 'ob-coq) diff --git a/lisp/ob-core.el b/lisp/ob-core.el index eef408f..30020f7 100644 --- a/lisp/ob-core.el +++ b/lisp/ob-core.el @@ -1,6 +1,6 @@ ;;; ob-core.el --- working with code blocks in org-mode -;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Authors: Eric Schulte ;; Dan Davison @@ -39,6 +39,7 @@ (defvar org-babel-library-of-babel) (declare-function show-all "outline" ()) (declare-function org-every "org" (pred seq)) +(declare-function org-remove-indentation "org" (code &optional n)) (declare-function org-reduce "org" (CL-FUNC CL-SEQ &rest CL-KEYS)) (declare-function org-mark-ring-push "org" (&optional pos buffer)) (declare-function tramp-compat-make-temp-file "tramp-compat" @@ -48,9 +49,8 @@ (declare-function tramp-file-name-host "tramp" (vec)) (declare-function with-parsed-tramp-file-name "tramp" (filename var &rest body)) (declare-function org-icompleting-read "org" (&rest args)) -(declare-function org-edit-src-code "org-src" - (&optional context code edit-buffer-name quietp)) -(declare-function org-edit-src-exit "org-src" (&optional context)) +(declare-function org-edit-src-code "org-src" (&optional code edit-buffer-name)) +(declare-function org-edit-src-exit "org-src" ()) (declare-function org-open-at-point "org" (&optional in-emacs reference-buffer)) (declare-function org-save-outline-visibility "org-macs" (use-markers &rest body)) (declare-function org-outline-overlay-data "org" (&optional use-markers)) @@ -96,7 +96,12 @@ (declare-function org-unescape-code-in-string "org-src" (s)) (declare-function org-table-to-lisp "org-table" (&optional txt)) (declare-function org-reverse-string "org" (string)) -(declare-function org-element-context "org-element" (&optional ELEMENT)) +(declare-function org-element-context "org-element" (&optional element)) +(declare-function org-element-type "org-element" (element)) +(declare-function org-element-at-point "org-element" ()) +(declare-function org-element-property "org-element" (property element)) +(declare-function org-every "org" (pred seq)) +(declare-function org-macro-escape-arguments "org-macro" (&rest args)) (defgroup org-babel nil "Code block evaluation and management in `org-mode' documents." @@ -135,12 +140,16 @@ remove code block execution from the C-c C-c keybinding." (defcustom org-babel-results-keyword "RESULTS" "Keyword used to name results generated by code blocks. -Should be either RESULTS or NAME however any capitalization may -be used." +It should be \"RESULTS\". However any capitalization may be +used." :group 'org-babel :version "24.4" :package-version '(Org . "8.0") - :type 'string) + :type 'string + :safe (lambda (v) + (and (stringp v) + (eq (compare-strings "RESULTS" nil nil v nil nil t) + t)))) (defcustom org-babel-noweb-wrap-start "<<" "String used to begin a noweb reference in a code block. @@ -159,6 +168,11 @@ See also `org-babel-noweb-wrap-start'." This string must include a \"%s\" which will be replaced by the results." :group 'org-babel :type 'string) +(put 'org-babel-inline-result-wrap + 'safe-local-variable + (lambda (value) + (and (stringp value) + (string-match-p "%s" value)))) (defun org-babel-noweb-wrap (&optional regexp) (concat org-babel-noweb-wrap-start @@ -173,14 +187,6 @@ This string must include a \"%s\" which will be replaced by the results." "^[ \t]*#\\+headers?:[ \t]*\\([^\n]*\\)$" "Regular expression used to match multi-line header arguments.") -(defvar org-babel-src-name-w-name-regexp - (concat org-babel-src-name-regexp - "\\(" - org-babel-multi-line-header-regexp - "\\)*" - "\\([^ ()\f\t\n\r\v]+\\)") - "Regular expression matching source name lines with a name.") - (defvar org-babel-src-block-regexp (concat ;; (1) indentation (2) lang @@ -196,9 +202,9 @@ This string must include a \"%s\" which will be replaced by the results." (defvar org-babel-inline-src-block-regexp (concat ;; (1) replacement target (2) lang - "\\(?:^\\|[^-[:alnum:]]\\)\\(src_\\([^ \f\t\n\r\v]+\\)" + "\\(?:^\\|[^-[:alnum:]]?\\)\\(src_\\([^ \f\t\n\r\v[]+\\)" ;; (3,4) (unused, headers) - "\\(\\|\\[\\(.*?\\)\\]\\)" + "\\(\\|\\[[ \t]*\\(.*?\\)\\]\\)" ;; (5) body "{\\([^\f\n\r\v]+?\\)}\\)") "Regexp used to identify inline src-blocks.") @@ -212,35 +218,24 @@ not match KEY should be returned." (lambda (p) (when (funcall (if others #'not #'identity) (eq (car p) key)) p)) params))) -(defun org-babel-get-inline-src-block-matches() +(defun org-babel-get-inline-src-block-matches () "Set match data if within body of an inline source block. Returns non-nil if match-data set" - (let ((src-at-0-p (save-excursion - (beginning-of-line 1) - (string= "src" (thing-at-point 'word)))) - (first-line-p (= (line-beginning-position) (point-min))) - (orig (point))) - (let ((search-for (cond ((and src-at-0-p first-line-p "src_")) - (first-line-p "[[:punct:] \t]src_") - (t "[[:punct:] \f\t\n\r\v]src_"))) - (lower-limit (if first-line-p - nil - (- (point-at-bol) 1)))) - (save-excursion - (when (or (and src-at-0-p (bobp)) - (and (re-search-forward "}" (point-at-eol) t) - (re-search-backward search-for lower-limit t) - (> orig (point)))) - (when (looking-at org-babel-inline-src-block-regexp) - t )))))) + (save-excursion + (let ((datum (org-element-context))) + (when (eq (org-element-type datum) 'inline-src-block) + (goto-char (org-element-property :begin datum)) + (when (looking-at org-babel-inline-src-block-regexp) + t ))))) (defvar org-babel-inline-lob-one-liner-regexp) -(defun org-babel-get-lob-one-liner-matches() +(defun org-babel-get-lob-one-liner-matches () "Set match data if on line of an lob one liner. Returns non-nil if match-data set" (save-excursion - (unless (= (point) (point-at-bol)) ;; move before inline block - (re-search-backward "[ \f\t\n\r\v]" nil t)) + (let ((datum (org-element-context))) + (when (eq (org-element-type datum) 'inline-babel-call) + (goto-char (org-element-property :begin datum)))) (if (looking-at org-babel-inline-lob-one-liner-regexp) t nil))) @@ -268,17 +263,24 @@ Returns a list (org-babel-merge-params (nth 2 info) (org-babel-parse-header-arguments (match-string 1))))) - (when (looking-at org-babel-src-name-w-name-regexp) - (setq name (org-no-properties (match-string 3))))) + (when (looking-at (org-babel-named-src-block-regexp-for-name)) + (setq name (org-match-string-no-properties 9)))) ;; inline source block (when (org-babel-get-inline-src-block-matches) + (setq head (match-beginning 0)) (setq info (org-babel-parse-inline-src-block-match)))) ;; resolve variable references and add summary parameters (when (and info (not light)) (setf (nth 2 info) (org-babel-process-params (nth 2 info)))) + (when info + (setf (nth 2 info) (org-babel-generate-file-param name (nth 2 info)))) (when info (append info (list name indent head))))) -(defvar org-current-export-file) ; dynamically bound +(defvar org-babel-exp-reference-buffer nil + "Buffer containing original contents of the exported buffer. +This is used by Babel to resolve references in source blocks. +Its value is dynamically bound during export.") + (defmacro org-babel-check-confirm-evaluate (info &rest body) "Evaluate BODY with special execution confirmation variables set. @@ -288,24 +290,27 @@ hold the language of the code block, and BLOCK-NAME will hold the name of the code block." (declare (indent defun)) (org-with-gensyms - (lang block-body headers name eval eval-no export eval-no-export) + (lang block-body headers name head eval eval-no export eval-no-export) `(let* ((,lang (nth 0 ,info)) (,block-body (nth 1 ,info)) (,headers (nth 2 ,info)) (,name (nth 4 ,info)) + (,head (nth 6 ,info)) (,eval (or (cdr (assoc :eval ,headers)) (when (assoc :noeval ,headers) "no"))) (,eval-no (or (equal ,eval "no") (equal ,eval "never"))) - (,export (org-bound-and-true-p org-current-export-file)) + (,export org-babel-exp-reference-buffer) (,eval-no-export (and ,export (or (equal ,eval "no-export") (equal ,eval "never-export")))) (noeval (or ,eval-no ,eval-no-export)) (query (or (equal ,eval "query") (and ,export (equal ,eval "query-export")) (if (functionp org-confirm-babel-evaluate) - (funcall org-confirm-babel-evaluate - ,lang ,block-body) + (save-excursion + (goto-char ,head) + (funcall org-confirm-babel-evaluate + ,lang ,block-body)) org-confirm-babel-evaluate))) (code-block (if ,info (format " %s " ,lang) " ")) (block-name (if ,name (format " (%s) " ,name) " "))) @@ -396,12 +401,16 @@ a window into the `org-babel-get-src-block-info' function." (header-args (nth 2 info))) (when name (funcall printf "Name: %s\n" name)) (when lang (funcall printf "Lang: %s\n" lang)) + (funcall printf "Properties:\n") + (funcall printf "\t:header-args \t%s\n" (org-entry-get (point) "header-args" t)) + (funcall printf "\t:header-args:%s \t%s\n" lang (org-entry-get (point) (concat "header-args:" lang) t)) + (when (funcall full switches) (funcall printf "Switches: %s\n" switches)) (funcall printf "Header Arguments:\n") (dolist (pair (sort header-args (lambda (a b) (string< (symbol-name (car a)) (symbol-name (car b)))))) - (when (funcall full (cdr pair)) + (when (funcall full (format "%s" (cdr pair))) (funcall printf "\t%S%s\t%s\n" (car pair) (if (> (length (format "%S" (car pair))) 7) "" "\t") @@ -444,11 +453,13 @@ then run `org-babel-switch-to-session'." (colnames . ((nil no yes))) (comments . ((no link yes org both noweb))) (dir . :any) - (eval . ((never query))) + (eval . ((yes no no-export strip-export never-export eval never + query))) (exports . ((code results both none))) (epilogue . :any) (file . :any) (file-desc . :any) + (file-ext . :any) (hlines . ((no yes))) (mkdirp . ((yes no))) (no-expand) @@ -456,6 +467,7 @@ then run `org-babel-switch-to-session'." (noweb . ((yes no tangle no-export strip-export))) (noweb-ref . :any) (noweb-sep . :any) + (output-dir . :any) (padline . ((yes no))) (post . :any) (prologue . :any) @@ -478,14 +490,55 @@ then run `org-babel-switch-to-session'." Note that individual languages may define their own language specific header arguments as well.") +(defconst org-babel-safe-header-args + '(:cache :colnames :comments :exports :epilogue :hlines :noeval + :noweb :noweb-ref :noweb-sep :padline :prologue :rownames + :sep :session :tangle :wrap + (:eval . ("never" "query")) + (:results . (lambda (str) (not (string-match "file" str))))) + "A list of safe header arguments for babel source blocks. + +The list can have entries of the following forms: +- :ARG -> :ARG is always a safe header arg +- (:ARG . (VAL1 VAL2 ...)) -> :ARG is safe as a header arg if it is + `equal' to one of the VALs. +- (:ARG . FN) -> :ARG is safe as a header arg if the function FN + returns non-nil. FN is passed one + argument, the value of the header arg + (as a string).") + +(defmacro org-babel-header-args-safe-fn (safe-list) + "Return a function that determines whether a list of header args are safe. + +Intended usage is: +\(put 'org-babel-default-header-args 'safe-local-variable + (org-babel-header-args-safe-p org-babel-safe-header-args) + +This allows org-babel languages to extend the list of safe values for +their `org-babel-default-header-args:foo' variable. + +For the format of SAFE-LIST, see `org-babel-safe-header-args'." + `(lambda (value) + (and (listp value) + (org-every + (lambda (pair) + (and (consp pair) + (org-babel-one-header-arg-safe-p pair ,safe-list))) + value)))) + (defvar org-babel-default-header-args '((:session . "none") (:results . "replace") (:exports . "code") (:cache . "no") (:noweb . "no") (:hlines . "no") (:tangle . "no")) "Default arguments to use when evaluating a source block.") +(put 'org-babel-default-header-args 'safe-local-variable + (org-babel-header-args-safe-fn org-babel-safe-header-args)) (defvar org-babel-default-inline-header-args - '((:session . "none") (:results . "replace") (:exports . "results")) + '((:session . "none") (:results . "replace") + (:exports . "results") (:hlines . "yes")) "Default arguments to use when evaluating an inline source block.") +(put 'org-babel-default-inline-header-args 'safe-local-variable + (org-babel-header-args-safe-fn org-babel-safe-header-args)) (defvar org-babel-data-names '("tblname" "results" "name")) @@ -512,11 +565,17 @@ block. Otherwise the output is marked as literal by inserting colons at the starts of the lines. This variable only takes effect if the :results output option is in effect.") +(defvar org-babel-noweb-error-all-langs nil + "Raise errors when noweb references don't resolve. +Also see `org-babel-noweb-error-langs' to control noweb errors on +a language by language bases.") + (defvar org-babel-noweb-error-langs nil "Languages for which Babel will raise literate programming errors. List of languages for which errors should be raised when the source code block satisfying a noweb reference in this language -can not be resolved.") +can not be resolved. Also see `org-babel-noweb-error-all-langs' +to raise errors for all languages.") (defvar org-babel-hash-show 4 "Number of initial characters to show of a hidden results hash.") @@ -527,10 +586,15 @@ can not be resolved.") (defvar org-babel-after-execute-hook nil "Hook for functions to be called after `org-babel-execute-src-block'") -(defun org-babel-named-src-block-regexp-for-name (name) - "This generates a regexp used to match a src block named NAME." - (concat org-babel-src-name-regexp (regexp-quote name) - "[ \t(]*[\r\n]\\(?:^#.*[\r\n]\\)*" +(defun org-babel-named-src-block-regexp-for-name (&optional name) + "This generates a regexp used to match a src block named NAME. +If NAME is nil, match any name. Matched name is then put in +match group 9. Other match groups are defined in +`org-babel-src-block-regexp'." + (concat org-babel-src-name-regexp + (concat (if name (regexp-quote name) "\\(?9:.*?\\)") "[ \t]*" ) + "\\(?:\n[ \t]*#\\+\\S-+:.*\\)*?" + "\n" (substring org-babel-src-block-regexp 1))) (defun org-babel-named-data-regexp-for-name (name) @@ -566,7 +630,10 @@ block." (let* ((org-babel-current-src-block-location (or org-babel-current-src-block-location (nth 6 info) - (org-babel-where-is-src-block-head))) + (org-babel-where-is-src-block-head) + ;; inline src block + (and (org-babel-get-inline-src-block-matches) + (match-beginning 0)))) (info (if info (copy-tree info) (org-babel-get-src-block-info))) @@ -586,7 +653,8 @@ block." (cache-current-p (save-excursion ;; return cached result (goto-char (org-babel-where-is-src-block-result nil info)) - (end-of-line 1) (forward-char 1) + (forward-line) + (skip-chars-forward " \t") (let ((result (org-babel-read-result))) (message (replace-regexp-in-string "%" "%%" (format "%S" result))) result))) @@ -709,8 +777,7 @@ arguments and pop open the results in a preview buffer." (funcall assignments-cmd params)))))) (if (org-called-interactively-p 'any) (org-edit-src-code - nil expanded - (concat "*Org-Babel Preview " (buffer-name) "[ " lang " ]*")) + expanded (concat "*Org-Babel Preview " (buffer-name) "[ " lang " ]*")) expanded))) (defun org-babel-edit-distance (s1 s2) @@ -770,37 +837,43 @@ arguments and pop open the results in a preview buffer." (message "No suspicious header arguments found."))) ;;;###autoload -(defun org-babel-insert-header-arg () +(defun org-babel-insert-header-arg (&optional header-arg value) "Insert a header argument selecting from lists of common args and values." (interactive) - (let* ((lang (car (org-babel-get-src-block-info 'light))) + (let* ((info (org-babel-get-src-block-info 'light)) + (lang (car info)) + (begin (nth 6 info)) (lang-headers (intern (concat "org-babel-header-args:" lang))) (headers (org-babel-combine-header-arg-lists org-babel-common-header-args-w-values (when (boundp lang-headers) (eval lang-headers)))) - (arg (org-icompleting-read - "Header Arg: " - (mapcar - (lambda (header-spec) (symbol-name (car header-spec))) - headers)))) - (insert ":" arg) - (let ((vals (cdr (assoc (intern arg) headers)))) - (when vals - (insert - " " - (cond - ((eq vals :any) - (read-from-minibuffer "value: ")) - ((listp vals) - (mapconcat - (lambda (group) - (let ((arg (org-icompleting-read - "value: " - (cons "default" (mapcar #'symbol-name group))))) - (if (and arg (not (string= "default" arg))) - (concat arg " ") - ""))) - vals "")))))))) + (header-arg (or header-arg + (org-icompleting-read + "Header Arg: " + (mapcar + (lambda (header-spec) (symbol-name (car header-spec))) + headers)))) + (vals (cdr (assoc (intern header-arg) headers))) + (value (or value + (cond + ((eq vals :any) + (read-from-minibuffer "value: ")) + ((listp vals) + (mapconcat + (lambda (group) + (let ((arg (org-icompleting-read + "Value: " + (cons "default" + (mapcar #'symbol-name group))))) + (if (and arg (not (string= "default" arg))) + (concat arg " ") + ""))) + vals "")))))) + (save-excursion + (goto-char begin) + (goto-char (point-at-eol)) + (unless (= (char-before (point)) ?\ ) (insert " ")) + (insert ":" header-arg) (when value (insert " " value))))) ;; Add support for completing-read insertion of header arguments after ":" (defun org-babel-header-arg-expand () @@ -912,15 +985,15 @@ with a prefix argument then this is passed on to (org-edit-src-code) (funcall swap-windows))) +;;;###autoload (defmacro org-babel-do-in-edit-buffer (&rest body) "Evaluate BODY in edit buffer if there is a code block at point. Return t if a code block was found at point, nil otherwise." `(let ((org-src-window-setup 'switch-invisibly)) (when (and (org-babel-where-is-src-block-head) - (org-edit-src-code nil nil nil)) + (org-edit-src-code)) (unwind-protect (progn ,@body) - (if (org-bound-and-true-p org-edit-src-from-org-mode) - (org-edit-src-exit))) + (org-edit-src-exit)) t))) (def-edebug-spec org-babel-do-in-edit-buffer (body)) @@ -941,7 +1014,7 @@ evaluation mechanisms." (defvar org-bracket-link-regexp) (defun org-babel-active-location-p () - (memq (car (save-match-data (org-element-context))) + (memq (org-element-type (save-match-data (org-element-context))) '(babel-call inline-babel-call inline-src-block src-block))) ;;;###autoload @@ -995,7 +1068,8 @@ beg-body --------- point at the beginning of the body end-body --------- point at the end of the body" (declare (indent 1)) (let ((tempvar (make-symbol "file"))) - `(let* ((,tempvar ,file) + `(let* ((case-fold-search t) + (,tempvar ,file) (visited-p (or (null ,tempvar) (get-file-buffer (expand-file-name ,tempvar)))) (point (point)) to-be-removed) @@ -1034,7 +1108,8 @@ If FILE is nil evaluate BODY forms on source blocks in current buffer." (declare (indent 1)) (let ((tempvar (make-symbol "file"))) - `(let* ((,tempvar ,file) + `(let* ((case-fold-search t) + (,tempvar ,file) (visited-p (or (null ,tempvar) (get-file-buffer (expand-file-name ,tempvar)))) (point (point)) to-be-removed) @@ -1158,7 +1233,20 @@ the current subtree." (member (car arg) '(:results :exports))) (mapconcat #'identity (sort (funcall rm (split-string v)) #'string<) " ")) - (t v))))))) + (t v)))))) + ;; expanded body + (lang (nth 0 info)) + (params (nth 2 info)) + (body (if (org-babel-noweb-p params :eval) + (org-babel-expand-noweb-references info) (nth 1 info))) + (expand-cmd (intern (concat "org-babel-expand-body:" lang))) + (assignments-cmd (intern (concat "org-babel-variable-assignments:" + lang))) + (expanded + (if (fboundp expand-cmd) (funcall expand-cmd body params) + (org-babel-expand-body:generic + body params (and (fboundp assignments-cmd) + (funcall assignments-cmd params)))))) (let* ((it (format "%s-%s" (mapconcat #'identity @@ -1167,19 +1255,19 @@ the current subtree." (when normalized (format "%S" normalized)))) (nth 2 info))) ":") - (nth 1 info))) + expanded)) (hash (sha1 it))) (when (org-called-interactively-p 'interactive) (message hash)) hash)))) -(defun org-babel-current-result-hash () +(defun org-babel-current-result-hash (&optional info) "Return the current in-buffer hash." - (org-babel-where-is-src-block-result) + (org-babel-where-is-src-block-result nil info) (org-no-properties (match-string 5))) -(defun org-babel-set-current-result-hash (hash) +(defun org-babel-set-current-result-hash (hash info) "Set the current in-buffer hash to HASH." - (org-babel-where-is-src-block-result) + (org-babel-where-is-src-block-result nil info) (save-excursion (goto-char (match-beginning 5)) (mapc #'delete-overlay (overlays-at (point))) (forward-char org-babel-hash-show) @@ -1321,33 +1409,31 @@ specified in the properties of the current outline entry." (save-match-data (list ;; DEPRECATED header arguments specified as separate property at - ;; point of definition - (let (val sym) - (org-babel-parse-multiple-vars - (delq nil - (mapcar - (lambda (header-arg) - (and (setq val (org-entry-get (point) header-arg t)) - (cons (intern (concat ":" header-arg)) - (org-babel-read val)))) - (mapcar - #'symbol-name - (mapcar - #'car - (org-babel-combine-header-arg-lists - org-babel-common-header-args-w-values - (progn - (setq sym (intern (concat "org-babel-header-args:" lang))) - (and (boundp sym) (eval sym)))))))))) + ;; point of definition. + (org-babel-parse-multiple-vars + (delq nil + (mapcar + (lambda (header) + (let* ((arg (symbol-name (car header))) + (val (org-entry-get (point) arg t))) + (and val + (cons (intern (concat ":" arg)) + (org-babel-read val))))) + (org-babel-combine-header-arg-lists + org-babel-common-header-args-w-values + (let ((sym (intern (concat "org-babel-header-args:" lang)))) + (and (boundp sym) (symbol-value sym))))))) ;; header arguments specified with the header-args property at - ;; point of call + ;; point of call. (org-babel-parse-header-arguments (org-entry-get org-babel-current-src-block-location - "header-args" 'inherit)) - (when lang ;; language-specific header arguments at point of call - (org-babel-parse-header-arguments - (org-entry-get org-babel-current-src-block-location - (concat "header-args:" lang) 'inherit)))))) + "header-args" + 'inherit)) + (and lang ; language-specific header arguments at point of call + (org-babel-parse-header-arguments + (org-entry-get org-babel-current-src-block-location + (concat "header-args:" lang) + 'inherit)))))) (defvar org-src-preserve-indentation) ;; declare defcustom from org-src (defun org-babel-parse-src-block-match () @@ -1395,7 +1481,8 @@ specified in the properties of the current outline entry." (append (org-babel-params-from-properties lang) (list (org-babel-parse-header-arguments - (org-no-properties (or (match-string 4) ""))))))))) + (org-no-properties (or (match-string 4) "")))))) + nil))) (defun org-babel-balanced-split (string alts) "Split STRING on instances of ALTS. @@ -1512,7 +1599,7 @@ shown below. ;; row and column names (defun org-babel-del-hlines (table) "Remove all 'hlines from TABLE." - (remove 'hline table)) + (remq 'hline table)) (defun org-babel-get-colnames (table) "Return the column names of TABLE. @@ -1608,33 +1695,20 @@ to the table for reinsertion to org-mode." (defun org-babel-where-is-src-block-head () "Find where the current source block begins. -Return the point at the beginning of the current source -block. Specifically at the beginning of the #+BEGIN_SRC line. +Return the point at the beginning of the current source block. +Specifically at the beginning of the #+BEGIN_SRC line. Also set +match-data relatively to `org-babel-src-block-regexp', which see. If the point is not on a source block then return nil." - (let ((initial (point)) (case-fold-search t) top bottom) - (or - (save-excursion ;; on a source name line or a #+header line - (beginning-of-line 1) - (and (or (looking-at org-babel-src-name-regexp) - (looking-at org-babel-multi-line-header-regexp)) - (progn - (while (and (forward-line 1) - (or (looking-at org-babel-src-name-regexp) - (looking-at org-babel-multi-line-header-regexp)))) - (looking-at org-babel-src-block-regexp)) - (point))) - (save-excursion ;; on a #+begin_src line - (beginning-of-line 1) - (and (looking-at org-babel-src-block-regexp) - (point))) - (save-excursion ;; inside a src block - (and - (re-search-backward "^[ \t]*#\\+begin_src" nil t) (setq top (point)) - (re-search-forward "^[ \t]*#\\+end_src" nil t) (setq bottom (point)) - (< top initial) (< initial bottom) - (progn (goto-char top) (beginning-of-line 1) - (looking-at org-babel-src-block-regexp)) - (point-marker)))))) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'src-block) + (let ((end (org-element-property :end element))) + (org-with-wide-buffer + ;; Ensure point is not on a blank line after the block. + (beginning-of-line) + (skip-chars-forward " \r\t\n" end) + (when (< (point) end) + (prog1 (goto-char (org-element-property :post-affiliated element)) + (looking-at org-babel-src-block-regexp)))))))) ;;;###autoload (defun org-babel-goto-src-block-head () @@ -1682,23 +1756,22 @@ If the point is not on a source block then return nil." (defun org-babel-find-named-block (name) "Find a named source-code block. Return the location of the source block identified by source -NAME, or nil if no such block exists. Set match data according to -org-babel-named-src-block-regexp." +NAME, or nil if no such block exists. Set match data according +to `org-babel-named-src-block-regexp'." (save-excursion - (let ((case-fold-search t) - (regexp (org-babel-named-src-block-regexp-for-name name)) msg) - (goto-char (point-min)) - (when (or (re-search-forward regexp nil t) - (re-search-backward regexp nil t)) - (match-beginning 0))))) + (goto-char (point-min)) + (ignore-errors + (org-next-block 1 nil (org-babel-named-src-block-regexp-for-name name))))) (defun org-babel-src-block-names (&optional file) "Returns the names of source blocks in FILE or the current buffer." + (when file (find-file file)) (save-excursion - (when file (find-file file)) (goto-char (point-min)) - (let ((case-fold-search t) names) - (while (re-search-forward org-babel-src-name-w-name-regexp nil t) - (setq names (cons (match-string 3) names))) + (goto-char (point-min)) + (let ((re (org-babel-named-src-block-regexp-for-name)) + names) + (while (ignore-errors (org-next-block 1 nil re)) + (push (org-match-string-no-properties 9) names)) names))) ;;;###autoload @@ -1777,10 +1850,14 @@ split. When called from outside of a code block a new code block is created. In both cases if the region is demarcated and if the region is not active then the point is demarcated." (interactive "P") - (let ((info (org-babel-get-src-block-info 'light)) - (headers (progn (org-babel-where-is-src-block-head) - (match-string 4))) - (stars (concat (make-string (or (org-current-level) 1) ?*) " "))) + (let* ((info (org-babel-get-src-block-info 'light)) + (start (org-babel-where-is-src-block-head)) + (block (and start (match-string 0))) + (headers (and start (match-string 4))) + (stars (concat (make-string (or (org-current-level) 1) ?*) " ")) + (lower-case-p (and block + (let (case-fold-search) + (org-string-match-p "#\\+begin_src" block))))) (if info (mapc (lambda (place) @@ -1794,9 +1871,10 @@ region is not active then the point is demarcated." (delete-region (point-at-bol) (point-at-eol))) (insert (concat (if (looking-at "^") "" "\n") - indent "#+end_src\n" + indent (funcall (if lower-case-p 'downcase 'upcase) "#+end_src\n") (if arg stars indent) "\n" - indent "#+begin_src " lang + indent (funcall (if lower-case-p 'downcase 'upcase) "#+begin_src ") + lang (if (> (length headers) 1) (concat " " headers) headers) (if (looking-at "[\n\r]") @@ -1816,11 +1894,12 @@ region is not active then the point is demarcated." (if (org-region-active-p) (mark) (point)) (point)))) (insert (concat (if (looking-at "^") "" "\n") (if arg (concat stars "\n") "") - "#+begin_src " lang "\n" + (funcall (if lower-case-p 'downcase 'upcase) "#+begin_src ") + lang "\n" body (if (or (= (length body) 0) (string-match "[\r\n]$" body)) "" "\n") - "#+end_src\n")) + (funcall (if lower-case-p 'downcase 'upcase) "#+end_src\n"))) (goto-char start) (move-end-of-line 1))))) (defvar org-babel-lob-one-liner-regexp) @@ -1865,26 +1944,30 @@ following the source block." (progn (end-of-line 1) (if (eobp) (insert "\n") (forward-char 1)) (setq end (point)) - (or (and - (not name) - (progn ;; unnamed results line already exists - (catch 'non-comment - (while (re-search-forward "[^ \f\t\n\r\v]" nil t) - (beginning-of-line 1) - (cond - ((looking-at (concat org-babel-result-regexp "\n")) - (throw 'non-comment t)) - ((looking-at "^[ \t]*#") (end-of-line 1)) - (t (throw 'non-comment nil)))))) - (let ((this-hash (match-string 5))) - (prog1 (point) - ;; must remove and rebuild if hash!=old-hash - (if (and hash (not (string= hash this-hash))) - (prog1 nil - (forward-line 1) - (delete-region - end (org-babel-result-end))) - (setq end nil))))))))))) + (and + (not name) + (progn ;; unnamed results line already exists + (catch 'non-comment + (while (re-search-forward "[^ \f\t\n\r\v]" nil t) + (beginning-of-line 1) + (cond + ((looking-at (concat org-babel-result-regexp "\n")) + (throw 'non-comment t)) + ((and (looking-at "^[ \t]*#") + (not (looking-at + org-babel-lob-one-liner-regexp))) + (end-of-line 1)) + (t (throw 'non-comment nil)))))) + (let ((this-hash (match-string 5))) + (prog1 (point) + ;; must remove and rebuild if hash!=old-hash + (if (and hash (not (string= hash this-hash))) + (progn + (setq end (point-at-bol)) + (forward-line 1) + (delete-region end (org-babel-result-end)) + (setq beg end)) + (setq end nil)))))))))) (if (not (and insert end)) found (goto-char end) (unless beg @@ -1912,7 +1995,7 @@ following the source block." ((org-at-table-p) (org-babel-read-table)) ((org-at-item-p) (org-babel-read-list)) ((looking-at org-bracket-link-regexp) (org-babel-read-link)) - ((looking-at org-block-regexp) (org-babel-trim (match-string 4))) + ((looking-at org-block-regexp) (org-remove-indentation (match-string 4))) ((or (looking-at "^[ \t]*: ") (looking-at "^[ \t]*:$")) (setq result-string (org-babel-trim @@ -1969,23 +2052,29 @@ If the path of the link is a file path it is expanded using (funcall echo-res result)))) (defun org-babel-insert-result - (result &optional result-params info hash indent lang) + (result &optional result-params info hash indent lang) "Insert RESULT into the current buffer. -By default RESULT is inserted after the end of the -current source block. With optional argument RESULT-PARAMS -controls insertion of results in the org-mode file. -RESULT-PARAMS can take the following values: + +By default RESULT is inserted after the end of the current source +block. The RESULT of an inline source block usually will be +wrapped inside a `results' macro and placed on the same line as +the inline source block. The macro is stripped upon export. +Multiline and non-scalar RESULTS from inline source blocks are +not allowed. With optional argument RESULT-PARAMS controls +insertion of results in the Org mode file. RESULT-PARAMS can +take the following values: replace - (default option) insert results after the source block - replacing any previously inserted results + or inline source block replacing any previously + inserted results. silent -- no results are inserted into the Org-mode buffer but the results are echoed to the minibuffer and are ingested by Emacs (a potentially time consuming - process) + process). file ---- the results are interpreted as a file path, and are - inserted into the buffer using the Org-mode file syntax + inserted into the buffer using the Org-mode file syntax. list ---- the results are interpreted as an Org-mode list. @@ -1994,26 +2083,49 @@ raw ----- results are added directly to the Org-mode file. This formatted text. drawer -- results are added directly to the Org-mode file as with - \"raw\", but are wrapped in a RESULTS drawer, allowing - them to later be replaced or removed automatically. + \"raw\", but are wrapped in a RESULTS drawer or results + macro, allowing them to later be replaced or removed + automatically. + +org ----- results are added inside of a \"src_org{}\" or \"#+BEGIN_SRC + org\" block depending on whether the current source block is + inline or not. They are not comma-escaped when inserted, + but Org syntax here will be discarded when exporting the + file. + +html ---- results are added inside of a #+BEGIN_HTML block or + html export snippet depending on whether the current + source block is inline or not. This is a good option + if your code block will output html formatted text. + +latex --- results are added inside of a #+BEGIN_LATEX block or + latex export snippet depending on whether the current + source block is inline or not. This is a good option + if your code block will output latex formatted text. -org ----- results are added inside of a \"#+BEGIN_SRC org\" block. - They are not comma-escaped when inserted, but Org syntax - here will be discarded when exporting the file. +code ---- the results are extracted in the syntax of the source + code of the language being evaluated and are added + inside of a source block with the source-code language + set appropriately. Also, source block inlining is + preserved in this case. Note this relies on the + optional LANG argument. -html ---- results are added inside of a #+BEGIN_HTML block. This - is a good option if you code block will output html - formatted text. +list ---- the results are rendered as a list. This option not + allowed for inline src blocks. -latex --- results are added inside of a #+BEGIN_LATEX block. - This is a good option if you code block will output - latex formatted text. +table --- the results are rendered as a table. This option not + allowed for inline src blocks. + +INFO may provide the values of these header arguments (in the +`header-arguments-alist' see the docstring for +`org-babel-get-src-block-info'): + +:file --- the name of the file to which output should be written. + +:wrap --- the effect is similar to `latex' in RESULT-PARAMS but + using the argument supplied to specify the export block + or snippet type." -code ---- the results are extracted in the syntax of the source - code of the language being evaluated and are added - inside of a #+BEGIN_SRC block with the source-code - language set appropriately. Note this relies on the - optional LANG argument." (if (stringp result) (progn (setq result (org-no-properties result)) @@ -2033,15 +2145,23 @@ code ---- the results are extracted in the syntax of the source (when (or (org-babel-get-inline-src-block-matches) (org-babel-get-lob-one-liner-matches)) (goto-char (match-end 0)) - (insert (if (listp result) "\n" " ")) + (org-babel-remove-inline-result) + (insert " ") (point)))) - (existing-result (unless inlinep - (org-babel-where-is-src-block-result - t info hash indent))) + (existing-result + (unless inlinep + (org-babel-where-is-src-block-result t info hash indent))) + (bad-inline-p + (when inlinep + (or + (and (member "table" result-params) "`:results table'") + (and (listp result) "list result") + (and (org-string-match-p "\n." result) "multiline result") + (and (member "list" result-params) "`:results list'")))) (results-switches (cdr (assoc :results_switches (nth 2 info)))) - (visible-beg (copy-marker (point-min))) - (visible-end (copy-marker (point-max))) + (visible-beg (point-min-marker)) + (visible-end (point-max-marker)) ;; When results exist outside of the current visible ;; region of the buffer, be sure to widen buffer to ;; update them. @@ -2074,18 +2194,37 @@ 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) "")) - (let ((wrap (lambda (start finish &optional no-escape) - (goto-char end) (insert (concat finish "\n")) - (goto-char beg) (insert (concat start "\n")) + (let ((wrap (lambda (start finish &optional no-escape no-newlines + inline-start inline-finish) + (when inlinep + (setq start inline-start) + (setq finish inline-finish) + (setq no-newlines t)) + (goto-char end) + (insert (concat finish (unless no-newlines "\n"))) + (goto-char beg) + (insert (concat start (unless no-newlines "\n"))) (unless no-escape (org-escape-code-in-region (min (point) end) end)) - (goto-char end) (goto-char (point-at-eol)) + (goto-char end) + (unless no-newlines (goto-char (point-at-eol))) (setq end (point-marker)))) - (proper-list-p (lambda (it) (and (listp it) (null (cdr (last it))))))) + (tabulablep + (lambda (r) + ;; Non-nil when result R can be turned into + ;; a table. + (and (listp r) + (null (cdr (last r))) + (org-every + (lambda (e) (or (atom e) (null (cdr (last e))))) + result))))) ;; insert results based on type (cond - ;; do nothing for an empty result + ;; Do nothing for an empty result. ((null result)) + ;; Illegal inline result or params. + (bad-inline-p + (error "Inline error: %s cannot be used" bad-inline-p)) ;; insert a list if preferred ((member "list" result-params) (insert @@ -2097,51 +2236,78 @@ code ---- the results are extracted in the syntax of the source (if (listp result) result (split-string result "\n" t)))) '(:splicep nil :istart "- " :iend "\n"))) "\n")) - ;; assume the result is a table if it's not a string - ((funcall proper-list-p result) + ;; Try hard to print RESULT as a table. Give up if + ;; it contains an improper list. + ((funcall tabulablep result) (goto-char beg) (insert (concat (orgtbl-to-orgtbl (if (org-every - (lambda (el) (or (listp el) (eq el 'hline))) + (lambda (e) + (or (eq e 'hline) (listp e))) result) - 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 (funcall proper-list-p result))) - (insert (format "%s\n" result))) + result + (list result)) + nil) + "\n")) + (goto-char beg) + (when (org-at-table-p) (org-table-align)) + (goto-char (org-table-end))) + ;; Print verbatim a list that cannot be turned into + ;; a table. + ((listp result) (insert (format "%s\n" result))) ((member "file" result-params) - (when inlinep (goto-char inlinep)) + (when inlinep + (goto-char inlinep) + (setq result (org-macro-escape-arguments result))) (insert result)) + ((and inlinep + (not (member "raw" result-params))) + (goto-char inlinep) + (insert (org-macro-escape-arguments + (org-babel-chomp result "\n")))) (t (goto-char beg) (insert result))) - (when (funcall proper-list-p result) (goto-char (org-table-end))) (setq end (point-marker)) ;; possibly wrap result (cond + (bad-inline-p) ; Do nothing. ((assoc :wrap (nth 2 info)) (let ((name (or (cdr (assoc :wrap (nth 2 info))) "RESULTS"))) (funcall wrap (concat "#+BEGIN_" name) - (concat "#+END_" (car (org-split-string name)))))) + (concat "#+END_" (car (org-split-string name))) + nil nil (concat "{{{results(@@" name ":") "@@)}}}"))) ((member "html" result-params) - (funcall wrap "#+BEGIN_HTML" "#+END_HTML")) + (funcall wrap "#+BEGIN_HTML" "#+END_HTML" nil nil + "{{{results(@@html:" "@@)}}}")) ((member "latex" result-params) - (funcall wrap "#+BEGIN_LaTeX" "#+END_LaTeX")) + (funcall wrap "#+BEGIN_LaTeX" "#+END_LaTeX" nil nil + "{{{results(@@latex:" "@@)}}}")) ((member "org" result-params) (goto-char beg) (if (org-at-table-p) (org-cycle)) - (funcall wrap "#+BEGIN_SRC org" "#+END_SRC")) + (funcall wrap "#+BEGIN_SRC org" "#+END_SRC" nil nil + "{{{results(src_org{" "})}}}")) ((member "code" result-params) - (funcall wrap (format "#+BEGIN_SRC %s%s" (or lang "none") results-switches) - "#+END_SRC")) + (let ((lang (or lang "none"))) + (funcall wrap (format "#+BEGIN_SRC %s%s" lang results-switches) + "#+END_SRC" nil nil + (format "{{{results(src_%s[%s]{" lang results-switches) + "})}}}"))) ((member "raw" result-params) (goto-char beg) (if (org-at-table-p) (org-cycle))) ((or (member "drawer" result-params) ;; Stay backward compatible with <7.9.2 (member "wrap" result-params)) (goto-char beg) (if (org-at-table-p) (org-cycle)) - (funcall wrap ":RESULTS:" ":END:" 'no-escape)) - ((and (not (funcall proper-list-p result)) + (funcall wrap ":RESULTS:" ":END:" 'no-escape nil + "{{{results(" ")}}}")) + ((and inlinep (member "file" result-params)) + (funcall wrap nil nil nil nil "{{{results(" ")}}}")) + ((and (not (funcall tabulablep result)) (not (member "file" result-params))) - (org-babel-examplize-region beg end results-switches) - (setq end (point))))) + (let ((org-babel-inline-result-wrap + ;; Hard code {{{results(...)}}} on top of customization. + (format "{{{results(%s)}}}" org-babel-inline-result-wrap))) + (org-babel-examplify-region beg end results-switches) + (setq end (point)))))) ;; possibly indent the results to match the #+results line (when (and (not inlinep) (numberp indent) indent (> indent 0) ;; in this case `table-align' does the work for us @@ -2157,15 +2323,44 @@ code ---- the results are extracted in the syntax of the source (set-marker visible-beg nil) (set-marker visible-end nil)))))) -(defun org-babel-remove-result (&optional info) +(defun org-babel-remove-result (&optional info keep-keyword) "Remove the result of the current source block." (interactive) - (let ((location (org-babel-where-is-src-block-result nil info)) start) + (let ((location (org-babel-where-is-src-block-result nil info))) (when location - (setq start (- location 1)) (save-excursion - (goto-char location) (forward-line 1) - (delete-region start (org-babel-result-end)))))) + (goto-char location) + (when (looking-at (concat org-babel-result-regexp ".*$")) + (delete-region + (if keep-keyword (1+ (match-end 0)) (1- (match-beginning 0))) + (progn (forward-line 1) (org-babel-result-end)))))))) + +(defun org-babel-remove-inline-result () + "Remove the result of the current inline-src-block or babel call. +The result must be wrapped in a `results' macro to be removed. +Leading whitespace is trimmed." + (interactive) + (let* ((el (org-element-context)) + (post-blank (org-element-property :post-blank el))) + (when (memq (org-element-type el) '(inline-src-block inline-babel-call)) + (org-with-wide-buffer + (goto-char (org-element-property :end el)) + (let ((el (org-element-context))) + (when (and (eq (org-element-type el) 'macro) + (string= (org-element-property :key el) "results")) + (delete-region ; And leading whitespace. + (- (org-element-property :begin el) post-blank) + (- (org-element-property :end el) + (org-element-property :post-blank el))))))))) + +(defun org-babel-remove-result-one-or-many (x) + "Remove the result of the current source block. +If called with a prefix argument, remove all result blocks +in the buffer." + (interactive "P") + (if x + (org-babel-map-src-blocks nil (org-babel-remove-result)) + (org-babel-remove-result))) (defun org-babel-result-end () "Return the point at the end of the current set of results." @@ -2203,18 +2398,27 @@ file's directory then expand relative links." result) (if description (concat "[" description "]") "")))) -(defvar org-babel-capitalize-examplize-region-markers nil +(defvar org-babel-capitalize-example-region-markers nil "Make true to capitalize begin/end example markers inserted by code blocks.") -(defun org-babel-examplize-region (beg end &optional results-switches) +(define-obsolete-function-alias + 'org-babel-examplize-region + 'org-babel-examplify-region "25.1") + +(defun org-babel-examplify-region (beg end &optional results-switches) "Comment out region using the inline '==' or ': ' org example quote." (interactive "*r") (let ((chars-between (lambda (b e) - (not (string-match "^[\\s]*$" (buffer-substring b e))))) - (maybe-cap (lambda (str) (if org-babel-capitalize-examplize-region-markers - (upcase str) str)))) - (if (or (funcall chars-between (save-excursion (goto-char beg) (point-at-bol)) beg) - (funcall chars-between end (save-excursion (goto-char end) (point-at-eol)))) + (not (string-match "^[\\s]*$" + (buffer-substring b e))))) + (maybe-cap (lambda (str) (if org-babel-capitalize-example-region-markers + (upcase str) str))) + (beg-bol (save-excursion (goto-char beg) (point-at-bol))) + (end-bol (save-excursion (goto-char end) (point-at-bol))) + (end-eol (save-excursion (goto-char end) (point-at-eol)))) + (if (and (not (= end end-bol)) + (or (funcall chars-between beg-bol beg) + (funcall chars-between end end-eol))) (save-excursion (goto-char beg) (insert (format org-babel-inline-result-wrap @@ -2242,7 +2446,8 @@ file's directory then expand relative links." (if (not (org-babel-where-is-src-block-head)) (error "Not in a source block") (save-match-data - (replace-match (concat (org-babel-trim new-body) "\n") nil t nil 5)) + (replace-match (concat (org-babel-trim (org-remove-indentation new-body)) + "\n") nil t nil 5)) (indent-rigidly (match-beginning 5) (match-end 5) 2))) (defun org-babel-merge-params (&rest plists) @@ -2331,6 +2536,16 @@ parameters when merging lists." (setq exports (funcall e-merge exports-exclusive-groups exports '("results")))) (setq params (cons pair (assq-delete-all (car pair) params))))) + (:file-ext + (when (cdr pair) + (setq results (funcall e-merge results-exclusive-groups + results '("file"))) + (unless (or (member "both" exports) + (member "none" exports) + (member "code" exports)) + (setq exports (funcall e-merge exports-exclusive-groups + exports '("results")))) + (setq params (cons pair (assq-delete-all (car pair) params))))) (:exports (setq exports (funcall e-merge exports-exclusive-groups exports (split-string (cdr pair))))) @@ -2523,7 +2738,8 @@ block but are passed literally to the \"example-block\"." (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) + (if (or org-babel-noweb-error-all-langs + (member lang org-babel-noweb-error-langs)) (error "%s" (concat (org-babel-noweb-wrap source-name) "could not be resolved (see " @@ -2533,60 +2749,106 @@ block but are passed literally to the \"example-block\"." (funcall nb-add (buffer-substring index (point-max)))) new-body)) +(defun org-babel--script-escape-inner (str) + (let (in-single in-double backslash out) + (mapc + (lambda (ch) + (setq + out + (if backslash + (progn + (setq backslash nil) + (cond + ((and in-single (eq ch ?')) + ;; Escaped single quote inside single quoted string: + ;; emit just a single quote, since we've changed the + ;; outer quotes to double. + (cons ch out)) + ((eq ch ?\") + ;; Escaped double quote + (if in-single + ;; This should be interpreted as backslash+quote, + ;; not an escape. Emit a three backslashes + ;; followed by a quote (because one layer of + ;; quoting will be stripped by `org-babel-read'). + (append (list ch ?\\ ?\\ ?\\) out) + ;; Otherwise we are in a double-quoted string. Emit + ;; a single escaped quote + (append (list ch ?\\) out))) + ((eq ch ?\\) + ;; Escaped backslash: emit a single escaped backslash + (append (list ?\\ ?\\) out)) + ;; Other: emit a quoted backslash followed by whatever + ;; the character was (because one layer of quoting will + ;; be stripped by `org-babel-read'). + (t (append (list ch ?\\ ?\\) out)))) + (case ch + (?\[ (if (or in-double in-single) + (cons ?\[ out) + (cons ?\( out))) + (?\] (if (or in-double in-single) + (cons ?\] out) + (cons ?\) out))) + (?\{ (if (or in-double in-single) + (cons ?\{ out) + (cons ?\( out))) + (?\} (if (or in-double in-single) + (cons ?\} out) + (cons ?\) out))) + (?, (if (or in-double in-single) + (cons ?, out) (cons ?\s out))) + (?\' (if in-double + (cons ?\' out) + (setq in-single (not in-single)) (cons ?\" out))) + (?\" (if in-single + (append (list ?\" ?\\) out) + (setq in-double (not in-double)) (cons ?\" out))) + (?\\ (unless (or in-single in-double) + (error "Can't handle backslash outside string in `org-babel-script-escape'")) + (setq backslash t) + out) + (t (cons ch out)))))) + (string-to-list str)) + (when (or in-single in-double) + (error "Unterminated string in `org-babel-script-escape'")) + (apply #'string (reverse out)))) + (defun org-babel-script-escape (str &optional force) "Safely convert tables into elisp lists." + (unless (stringp str) + (error "`org-babel-script-escape' expects a string")) (let ((escaped - (if (or force - (and (stringp str) - (> (length str) 2) - (or (and (string-equal "[" (substring str 0 1)) - (string-equal "]" (substring str -1))) - (and (string-equal "{" (substring str 0 1)) - (string-equal "}" (substring str -1))) - (and (string-equal "(" (substring str 0 1)) - (string-equal ")" (substring str -1)))))) - (org-babel-read - (concat - "'" - (let (in-single in-double out) - (mapc - (lambda (ch) - (setq - out - (case ch - (91 (if (or in-double in-single) ; [ - (cons 91 out) - (cons 40 out))) - (93 (if (or in-double in-single) ; ] - (cons 93 out) - (cons 41 out))) - (123 (if (or in-double in-single) ; { - (cons 123 out) - (cons 40 out))) - (125 (if (or in-double in-single) ; } - (cons 125 out) - (cons 41 out))) - (44 (if (or in-double in-single) ; , - (cons 44 out) (cons 32 out))) - (39 (if in-double ; ' - (cons 39 out) - (setq in-single (not in-single)) (cons 34 out))) - (34 (if in-single ; " - (append (list 34 32) out) - (setq in-double (not in-double)) (cons 34 out))) - (t (cons ch out))))) - (string-to-list str)) - (apply #'string (reverse out))))) - str))) + (cond + ((and (> (length str) 2) + (or (and (string-equal "[" (substring str 0 1)) + (string-equal "]" (substring str -1))) + (and (string-equal "{" (substring str 0 1)) + (string-equal "}" (substring str -1))) + (and (string-equal "(" (substring str 0 1)) + (string-equal ")" (substring str -1))))) + + (concat "'" (org-babel--script-escape-inner str))) + ((or force + (and (> (length str) 2) + (or (and (string-equal "'" (substring str 0 1)) + (string-equal "'" (substring str -1))) + ;; We need to pass double-quoted strings + ;; through the backslash-twiddling bits, even + ;; though we don't need to change their + ;; delimiters. + (and (string-equal "\"" (substring str 0 1)) + (string-equal "\"" (substring str -1)))))) + (org-babel--script-escape-inner str)) + (t str)))) (condition-case nil (org-babel-read escaped) (error escaped)))) (defun org-babel-read (cell &optional inhibit-lisp-eval) "Convert the string value of CELL to a number if appropriate. -Otherwise if cell looks like lisp (meaning it starts with a -\"(\", \"'\", \"`\" or a \"[\") then read it as lisp, -otherwise return it unmodified as a string. Optional argument -NO-LISP-EVAL inhibits lisp evaluation for situations in which is -it not appropriate." +Otherwise if CELL looks like lisp (meaning it starts with a +\"(\", \"'\", \"\\=`\" or a \"[\") then read and evaluate it as +lisp, otherwise return it unmodified as a string. Optional +argument INHIBIT-LISP-EVAL inhibits lisp evaluation for +situations in which is it not appropriate." (if (and (stringp cell) (not (equal cell ""))) (or (org-babel-number-p cell) (if (and (not inhibit-lisp-eval) @@ -2637,9 +2899,9 @@ If the table is trivial, then return it as a scalar." cell) t)) (defun org-babel-chomp (string &optional regexp) - "Strip trailing spaces and carriage returns from STRING. -Default regexp used is \"[ \f\t\n\r\v]\" but can be -overwritten by specifying a regexp as a second argument." + "Strip a trailing space or carriage return from STRING. +The default regexp used is \"[ \\f\\t\\n\\r\\v]\" but another one +can be specified as the REGEXP argument." (let ((regexp (or regexp "[ \f\t\n\r\v]"))) (while (and (> (length string) 0) (string-match regexp (substring string -1))) @@ -2647,12 +2909,12 @@ overwritten by specifying a regexp as a second argument." string)) (defun org-babel-trim (string &optional regexp) - "Strip leading and trailing spaces and carriage returns from STRING. -Like `org-babel-chomp' only it runs on both the front and back -of the string." - (org-babel-chomp (org-reverse-string - (org-babel-chomp (org-reverse-string string) regexp)) - regexp)) + "Strip a leading and trailing space or carriage return from STRING. +Like `org-babel-chomp', but run on both the first and last +character of the string." + (org-babel-chomp + (org-reverse-string + (org-babel-chomp (org-reverse-string string) regexp)) regexp)) (defun org-babel-tramp-handle-call-process-region (start end program &optional delete buffer display &rest args) @@ -2675,11 +2937,7 @@ Fixes a bug in `tramp-handle-call-process-region'." (defun org-babel-local-file-name (file) "Return the local name component of FILE." - (if (file-remote-p file) - (let (localname) - (with-parsed-tramp-file-name file nil - localname)) - file)) + (or (file-remote-p file 'localname) file)) (defun org-babel-process-file-name (name &optional no-quote-p) "Prepare NAME to be used in an external process. @@ -2688,7 +2946,7 @@ name is removed, since in that case the process will be executing remotely. The file name is then processed by `expand-file-name'. Unless second argument NO-QUOTE-P is non-nil, the file name is additionally processed by `shell-quote-argument'" - (let ((f (expand-file-name (org-babel-local-file-name name)))) + (let ((f (org-babel-local-file-name (expand-file-name name)))) (if no-quote-p f (shell-quote-argument f)))) (defvar org-babel-temporary-directory) @@ -2702,6 +2960,11 @@ additionally processed by `shell-quote-argument'" Used by `org-babel-temp-file'. This directory will be removed on Emacs shutdown.")) +(defcustom org-babel-remote-temporary-directory "/tmp/" + "Directory to hold temporary files on remote hosts." + :group 'org-babel + :type 'string) + (defmacro org-babel-result-cond (result-params scalar-form &rest table-forms) "Call the code to parse raw string results according to RESULT-PARAMS." (declare (indent 1) @@ -2714,6 +2977,7 @@ Emacs shutdown.")) (member "html" ,params) (member "code" ,params) (member "pp" ,params) + (member "file" ,params) (and (or (member "output" ,params) (member "raw" ,params) (member "org" ,params) @@ -2731,7 +2995,8 @@ of `org-babel-temporary-directory'." (if (file-remote-p default-directory) (let ((prefix (concat (file-remote-p default-directory) - (expand-file-name prefix temporary-file-directory)))) + (expand-file-name + prefix org-babel-remote-temporary-directory)))) (make-temp-file prefix nil suffix)) (let ((temporary-file-directory (or (and (boundp 'org-babel-temporary-directory) @@ -2766,6 +3031,69 @@ of `org-babel-temporary-directory'." (add-hook 'kill-emacs-hook 'org-babel-remove-temporary-directory) +(defun org-babel-one-header-arg-safe-p (pair safe-list) + "Determine if the PAIR is a safe babel header arg according to SAFE-LIST. + +For the format of SAFE-LIST, see `org-babel-safe-header-args'." + (and (consp pair) + (keywordp (car pair)) + (stringp (cdr pair)) + (or + (memq (car pair) safe-list) + (let ((entry (assq (car pair) safe-list))) + (and entry + (consp entry) + (cond ((functionp (cdr entry)) + (funcall (cdr entry) (cdr pair))) + ((listp (cdr entry)) + (member (cdr pair) (cdr entry))) + (t nil))))))) + +(defun org-babel-generate-file-param (src-name params) + "Calculate the filename for source block results. + +The directory is calculated from the :output-dir property of the +source block; if not specified, use the current directory. + +If the source block has a #+NAME and the :file parameter does not +contain any period characters, then the :file parameter is +treated as an extension, and the output file name is the +concatenation of the directory (as calculated above), the block +name, a period, and the parameter value as a file extension. +Otherwise, the :file parameter is treated as a full file name, +and the output file name is the directory (as calculated above) +plus the parameter value." + (let* ((file-cons (assq :file params)) + (file-ext-cons (assq :file-ext params)) + (file-ext (cdr-safe file-ext-cons)) + (dir (cdr-safe (assq :output-dir params))) + fname) + ;; create the output-dir if it does not exist + (when dir + (make-directory dir t)) + (if file-cons + ;; :file given; add :output-dir if given + (when dir + (setcdr file-cons (concat (file-name-as-directory dir) (cdr file-cons)))) + ;; :file not given; compute from name and :file-ext if possible + (when (and src-name file-ext) + (if dir + (setq fname (concat (file-name-as-directory (or dir "")) + src-name "." file-ext)) + (setq fname (concat src-name "." file-ext))) + (setq params (cons (cons :file fname) params)))) + params)) + +;;; Used by backends: R, Maxima, Octave. +(defun org-babel-graphical-output-file (params) + "File where a babel block should send graphical output, per PARAMS." + (unless (assq :file params) + (if (assq :file-ext params) + (user-error ":file-ext given but no :file generated; did you forget to give a block a #+NAME?") + (user-error "No :file header argument given; cannot create graphical result."))) + (and (member "graphics" (cdr (assq :result-params params))) + (cdr (assq :file params)))) + (provide 'ob-core) ;; Local variables: diff --git a/lisp/ob-ditaa.el b/lisp/ob-ditaa.el index 26f0e4f..888cafc 100644 --- a/lisp/ob-ditaa.el +++ b/lisp/ob-ditaa.el @@ -90,6 +90,14 @@ This function is called by `org-babel-execute-src-block'." (java (cdr (assoc :java params))) (in-file (org-babel-temp-file "ditaa-")) (eps (cdr (assoc :eps params))) + (eps-file (when eps + (org-babel-process-file-name (concat in-file ".eps")))) + (pdf-cmd (when (and (or (string= (file-name-extension out-file) "pdf") + (cdr (assoc :pdf params)))) + (concat + "epstopdf" + " " eps-file + " -o=" (org-babel-process-file-name out-file)))) (cmd (concat org-babel-ditaa-java-cmd " " java " " org-ditaa-jar-option " " (shell-quote-argument @@ -97,13 +105,9 @@ This function is called by `org-babel-execute-src-block'." (if eps org-ditaa-eps-jar-path org-ditaa-jar-path))) " " cmdline " " (org-babel-process-file-name in-file) - " " (org-babel-process-file-name out-file))) - (pdf-cmd (when (and (or (string= (file-name-extension out-file) "pdf") - (cdr (assoc :pdf params)))) - (concat - "epstopdf" - " " (org-babel-process-file-name (concat in-file ".eps")) - " -o=" (org-babel-process-file-name out-file))))) + " " (if pdf-cmd + eps-file + (org-babel-process-file-name out-file))))) (unless (file-exists-p org-ditaa-jar-path) (error "Could not find ditaa.jar at %s" org-ditaa-jar-path)) (with-temp-file in-file (insert body)) diff --git a/lisp/ob-dot.el b/lisp/ob-dot.el index b35d7bb..1e399e7 100644 --- a/lisp/ob-dot.el +++ b/lisp/ob-dot.el @@ -55,7 +55,9 @@ (replace-regexp-in-string (concat "\$" (regexp-quote name)) (if (stringp value) value (format "%S" value)) - body)))) + body + t + t)))) vars) body)) diff --git a/lisp/ob-ebnf.el b/lisp/ob-ebnf.el new file mode 100644 index 0000000..8c98d30 --- /dev/null +++ b/lisp/ob-ebnf.el @@ -0,0 +1,85 @@ +;;; ob-ebnf.el --- org-babel functions for ebnf evaluation + +;; Copyright (C) 2013 Free Software Foundation, Inc. + +;; Author: Michael Gauland +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 1.00 + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Org-Babel support for using ebnf2ps to generate encapsulated postscript +;;; railroad diagrams. It recogises these arguments: +;;; +;;; :file is required; it must include the extension '.eps.' All the rules +;;; in the block will be drawn in the same file. This is done by +;;; inserting a '[<file>' comment at the start of the block (see the +;;; documentation for ebnf-eps-buffer for more information). +;;; +;;; :style specifies a value in ebnf-style-database. This provides the +;;; ability to customise the output. The style can also specify the +;;; grammar syntax (by setting ebnf-syntax); note that only ebnf, +;;; iso-ebnf, and yacc are supported by this file. + +;;; Requirements: + +;;; Code: +(require 'ob) +(require 'ebnf2ps) + +;; optionally declare default header arguments for this language +(defvar org-babel-default-header-args:ebnf '((:style . nil))) + +;; Use ebnf-eps-buffer to produce an encapsulated postscript file. +;; +(defun org-babel-execute:ebnf (body params) + "Execute a block of Ebnf code with org-babel. This function is +called by `org-babel-execute-src-block'" + (save-excursion + (let* ((dest-file (cdr (assoc :file params))) + (dest-dir (file-name-directory dest-file)) + (dest-root (file-name-sans-extension + (file-name-nondirectory dest-file))) + (dest-ext (file-name-extension dest-file)) + (style (cdr (assoc :style params))) + (current-dir default-directory) + (result nil)) + (with-temp-buffer + (when style (ebnf-push-style style)) + (let ((comment-format + (cond ((string= ebnf-syntax 'yacc) "/*%s*/") + ((string= ebnf-syntax 'ebnf) ";%s") + ((string= ebnf-syntax 'iso-ebnf) "(*%s*)") + (t (setq result + (format "EBNF error: format %s not supported." + ebnf-syntax)))))) + (setq ebnf-eps-prefix dest-dir) + (insert (format comment-format (format "[%s" dest-root))) + (newline) + (insert body) + (newline) + (insert (format comment-format (format "]%s" dest-root))) + (ebnf-eps-buffer) + (when style (ebnf-pop-style)))) + result))) + +(provide 'ob-ebnf) +;;; ob-ebnf.el ends here diff --git a/lisp/ob-emacs-lisp.el b/lisp/ob-emacs-lisp.el index 3219344..f9f3671 100644 --- a/lisp/ob-emacs-lisp.el +++ b/lisp/ob-emacs-lisp.el @@ -28,12 +28,9 @@ ;;; Code: (require 'ob) -(defvar org-babel-default-header-args:emacs-lisp - '((:hlines . "yes") (:colnames . "no")) +(defvar org-babel-default-header-args:emacs-lisp nil "Default arguments for evaluating an emacs-lisp source block.") -(declare-function orgtbl-to-generic "org-table" (table params)) - (defun org-babel-expand-body:emacs-lisp (body params) "Expand BODY according to PARAMS, return the expanded body." (let* ((vars (mapcar #'cdr (org-babel-get-header params :var))) diff --git a/lisp/ob-eval.el b/lisp/ob-eval.el index 057590f..b3ce2af 100644 --- a/lisp/ob-eval.el +++ b/lisp/ob-eval.el @@ -57,6 +57,13 @@ STDERR with `org-babel-eval-error-notify'." (progn (with-current-buffer err-buff (org-babel-eval-error-notify exit-code (buffer-string))) + (save-excursion + (when (get-buffer org-babel-error-buffer-name) + (with-current-buffer org-babel-error-buffer-name + (unless (derived-mode-p 'compilation-mode) + (compilation-mode)) + ;; Compilation-mode enforces read-only, but Babel expects the buffer modifiable. + (setq buffer-read-only nil)))) nil) (buffer-string))))) diff --git a/lisp/ob-exp.el b/lisp/ob-exp.el index 761c9f1..9707141 100644 --- a/lisp/ob-exp.el +++ b/lisp/ob-exp.el @@ -28,7 +28,6 @@ (eval-when-compile (require 'cl)) -(defvar org-current-export-file) (defvar org-babel-lob-one-liner-regexp) (defvar org-babel-ref-split-regexp) (defvar org-list-forbidden-blocks) @@ -39,15 +38,17 @@ (start-re end-re &optional lim-up lim-down)) (declare-function org-get-indentation "org" (&optional line)) (declare-function org-heading-components "org" ()) +(declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) (declare-function org-in-block-p "org" (names)) (declare-function org-in-verbatim-emphasis "org" ()) -(declare-function org-link-search "org" (s &optional type avoid-pos stealth)) +(declare-function org-link-search "org" (s &optional avoid-pos stealth)) (declare-function org-fill-template "org" (template alist)) (declare-function org-split-string "org" (string &optional separators)) -(declare-function org-element-at-point "org-element" (&optional keep-trail)) +(declare-function org-element-at-point "org-element" ()) (declare-function org-element-context "org-element" ()) (declare-function org-element-property "org-element" (property element)) (declare-function org-element-type "org-element" (element)) +(declare-function org-id-get "org-id" (&optional pom create prefix)) (declare-function org-escape-code-in-string "org-src" (s)) (defcustom org-export-babel-evaluate t @@ -62,35 +63,35 @@ be executed." (const :tag "Always" t))) (put 'org-export-babel-evaluate 'safe-local-variable (lambda (x) (eq x nil))) -(defun org-babel-exp-get-export-buffer () - "Return the current export buffer if possible." - (cond - ((bufferp org-current-export-file) org-current-export-file) - (org-current-export-file (get-file-buffer org-current-export-file)) - ('otherwise - (error "Requested export buffer when `org-current-export-file' is nil")))) - (defvar org-link-search-inhibit-query) - (defmacro org-babel-exp-in-export-file (lang &rest body) (declare (indent 1)) `(let* ((lang-headers (intern (concat "org-babel-default-header-args:" ,lang))) - (heading (nth 4 (ignore-errors (org-heading-components)))) + (heading-query (or (org-id-get) + ;; CUSTOM_IDs don't work, maybe they are + ;; stripped, or maybe they resolve too + ;; late in `org-link-search'. + ;; (org-entry-get nil "CUSTOM_ID") + (nth 4 (ignore-errors (org-heading-components))))) (export-buffer (current-buffer)) - (original-buffer (org-babel-exp-get-export-buffer)) results) - (when original-buffer - ;; resolve parameters in the original file so that - ;; headline and file-wide parameters are included, attempt - ;; to go to the same heading in the original file - (set-buffer original-buffer) + results) + (when org-babel-exp-reference-buffer + ;; Resolve parameters in the original file so that headline and + ;; file-wide parameters are included, attempt to go to the same + ;; heading in the original file + (set-buffer org-babel-exp-reference-buffer) (save-restriction - (when heading + (when heading-query (condition-case nil (let ((org-link-search-inhibit-query t)) - (org-link-search heading)) - (error (when heading + ;; TODO: When multiple headings have the same title, + ;; this returns the first, which is not always + ;; the right heading. Consider a better way to + ;; find the proper heading. + (org-link-search heading-query)) + (error (when heading-query (goto-char (point-min)) - (re-search-forward (regexp-quote heading) nil t))))) + (re-search-forward (regexp-quote heading-query) nil t))))) (setq results ,@body)) (set-buffer export-buffer) results))) @@ -113,12 +114,14 @@ none ---- do not display either code or results upon export Assume point is at the beginning of block's starting line." (interactive) - (unless noninteractive (message "org-babel-exp processing...")) (save-excursion (let* ((info (org-babel-get-src-block-info 'light)) + (line (org-current-line)) (lang (nth 0 info)) (raw-params (nth 2 info)) hash) ;; bail if we couldn't get any info from the block + (unless noninteractive + (message "org-babel-exp process %s at line %d..." lang line)) (when info ;; if we're actually going to need the parameters (when (member (cdr (assoc :exports (nth 2 info))) '("both" "results")) @@ -151,138 +154,152 @@ this template." :type 'string) (defvar org-babel-default-lob-header-args) -(defun org-babel-exp-process-buffer () - "Execute all Babel blocks in current buffer." +(defun org-babel-exp-process-buffer (reference-buffer) + "Execute all Babel blocks in current buffer. +REFERENCE-BUFFER is the buffer containing a pristine copy of the +buffer being processed. It is used to properly resolve +references in source blocks, as modifications in current buffer +may make them unreachable." (interactive) (save-window-excursion (save-excursion (let ((case-fold-search t) + (org-babel-exp-reference-buffer reference-buffer) (regexp (concat org-babel-inline-src-block-regexp "\\|" org-babel-lob-one-liner-regexp "\\|" "^[ \t]*#\\+BEGIN_SRC"))) (goto-char (point-min)) (while (re-search-forward regexp nil t) - (let* ((element (save-excursion - ;; If match is inline, point is at its - ;; end. Move backward so - ;; `org-element-context' can get the - ;; object, not the following one. - (backward-char) - (save-match-data (org-element-context)))) - (type (org-element-type element)) - (begin (copy-marker (org-element-property :begin element))) - (end (copy-marker - (save-excursion - (goto-char (org-element-property :end element)) - (skip-chars-backward " \r\t\n") - (point))))) - (case type - (inline-src-block - (let* ((info (org-babel-parse-inline-src-block-match)) - (params (nth 2 info))) - (setf (nth 1 info) - (if (and (cdr (assoc :noweb params)) - (string= "yes" (cdr (assoc :noweb params)))) - (org-babel-expand-noweb-references - info (org-babel-exp-get-export-buffer)) - (nth 1 info))) - (goto-char begin) - (let ((replacement (org-babel-exp-do-export info 'inline))) - (if (equal replacement "") - ;; Replacement code is empty: remove inline src - ;; block, including extra white space that - ;; might have been created when inserting - ;; results. - (delete-region begin - (progn (goto-char end) - (skip-chars-forward " \t") - (point))) - ;; Otherwise: remove inline src block but - ;; preserve following white spaces. Then insert - ;; value. - (delete-region begin end) - (insert replacement))))) - ((babel-call inline-babel-call) - (let* ((lob-info (org-babel-lob-get-info)) - (results - (org-babel-exp-do-export - (list "emacs-lisp" "results" - (apply #'org-babel-merge-params - org-babel-default-header-args - org-babel-default-lob-header-args - (append - (org-babel-params-from-properties) - (list - (org-babel-parse-header-arguments - (org-no-properties - (concat - ":var results=" - (mapconcat 'identity - (butlast lob-info 2) - " "))))))) - "" (nth 3 lob-info) (nth 2 lob-info)) - 'lob)) - (rep (org-fill-template - org-babel-exp-call-line-template - `(("line" . ,(nth 0 lob-info)))))) - ;; If replacement is empty, completely remove the - ;; object/element, including any extra white space - ;; that might have been created when including - ;; results. - (if (equal rep "") - (delete-region - begin - (progn (goto-char end) - (if (not (eq type 'babel-call)) - (progn (skip-chars-forward " \t") (point)) - (skip-chars-forward " \r\t\n") - (line-beginning-position)))) - ;; Otherwise, preserve following white - ;; spaces/newlines and then, insert replacement - ;; string. + (unless (save-match-data (org-in-commented-heading-p)) + (let* ((element (save-excursion + ;; If match is inline, point is at its + ;; end. Move backward so + ;; `org-element-context' can get the + ;; object, not the following one. + (backward-char) + (save-match-data (org-element-context)))) + (type (org-element-type element)) + (begin (copy-marker (org-element-property :begin element))) + (end (copy-marker + (save-excursion + (goto-char (org-element-property :end element)) + (skip-chars-backward " \r\t\n") + (point))))) + (case type + (inline-src-block + (let* ((head (match-beginning 0)) + (info (append (org-babel-parse-inline-src-block-match) + (list nil nil head))) + (params (nth 2 info))) + (setf (nth 1 info) + (if (and (cdr (assoc :noweb params)) + (string= "yes" (cdr (assoc :noweb params)))) + (org-babel-expand-noweb-references + info org-babel-exp-reference-buffer) + (nth 1 info))) (goto-char begin) - (delete-region begin end) - (insert rep)))) - (src-block - (let* ((match-start (copy-marker (match-beginning 0))) - (ind (org-get-indentation)) - (headers - (cons - (org-element-property :language element) - (let ((params (org-element-property :parameters - element))) - (and params (org-split-string params "[ \t]+")))))) - ;; Take care of matched block: compute replacement - ;; string. In particular, a nil REPLACEMENT means - ;; the block should be left as-is while an empty - ;; string should remove the block. - (let ((replacement (progn (goto-char match-start) - (org-babel-exp-src-block headers)))) - (cond ((not replacement) (goto-char end)) - ((equal replacement "") - (goto-char end) - (skip-chars-forward " \r\t\n") - (beginning-of-line) - (delete-region begin (point))) - (t - (goto-char match-start) - (delete-region (point) - (save-excursion (goto-char end) - (line-end-position))) - (insert replacement) - (if (or org-src-preserve-indentation - (org-element-property :preserve-indent - element)) - ;; Indent only the code block markers. - (save-excursion (skip-chars-backward " \r\t\n") - (indent-line-to ind) - (goto-char match-start) - (indent-line-to ind)) - ;; Indent everything. - (indent-rigidly match-start (point) ind))))) - (set-marker match-start nil)))) - (set-marker begin nil) - (set-marker end nil))))))) + (let ((replacement (org-babel-exp-do-export info 'inline))) + (if (equal replacement "") + ;; Replacement code is empty: remove inline + ;; source block, including extra white space + ;; that might have been created when + ;; inserting results. + (delete-region begin + (progn (goto-char end) + (skip-chars-forward " \t") + (point))) + ;; Otherwise: remove inline src block but + ;; preserve following white spaces. Then + ;; insert value. + (delete-region begin end) + (insert replacement))))) + ((babel-call inline-babel-call) + (let* ((lob-info (org-babel-lob-get-info)) + (results + (org-babel-exp-do-export + (list "emacs-lisp" "results" + (apply #'org-babel-merge-params + org-babel-default-header-args + org-babel-default-lob-header-args + (append + (org-babel-params-from-properties) + (list + (org-babel-parse-header-arguments + (org-no-properties + (concat + ":var results=" + (mapconcat 'identity + (butlast lob-info 2) + " "))))))) + "" (nth 3 lob-info) (nth 2 lob-info)) + 'lob)) + (rep (org-fill-template + org-babel-exp-call-line-template + `(("line" . ,(nth 0 lob-info)))))) + ;; If replacement is empty, completely remove the + ;; object/element, including any extra white space + ;; that might have been created when including + ;; results. + (if (equal rep "") + (delete-region + begin + (progn (goto-char end) + (if (not (eq type 'babel-call)) + (progn (skip-chars-forward " \t") (point)) + (skip-chars-forward " \r\t\n") + (line-beginning-position)))) + ;; Otherwise, preserve following white + ;; spaces/newlines and then, insert replacement + ;; string. + (goto-char begin) + (delete-region begin end) + (insert rep)))) + (src-block + (let* ((match-start (copy-marker (match-beginning 0))) + (ind (org-get-indentation)) + (lang (or (org-element-property :language element) + (user-error + "No language for src block: %s" + (or (org-element-property :name element) + "(unnamed)")))) + (headers + (cons lang + (let ((params + (org-element-property + :parameters element))) + (and params (org-split-string params)))))) + ;; Take care of matched block: compute replacement + ;; string. In particular, a nil REPLACEMENT means + ;; the block should be left as-is while an empty + ;; string should remove the block. + (let ((replacement + (progn (goto-char match-start) + (org-babel-exp-src-block headers)))) + (cond ((not replacement) (goto-char end)) + ((equal replacement "") + (goto-char end) + (skip-chars-forward " \r\t\n") + (beginning-of-line) + (delete-region begin (point))) + (t + (goto-char match-start) + (delete-region (point) + (save-excursion (goto-char end) + (line-end-position))) + (insert replacement) + (if (or org-src-preserve-indentation + (org-element-property :preserve-indent + element)) + ;; Indent only the code block markers. + (save-excursion (skip-chars-backward " \r\t\n") + (indent-line-to ind) + (goto-char match-start) + (indent-line-to ind)) + ;; Indent everything. + (indent-rigidly match-start (point) ind))))) + (set-marker match-start nil)))) + (set-marker begin nil) + (set-marker end nil)))))))) (defun org-babel-in-example-or-verbatim () "Return true if point is in example or verbatim code. @@ -303,13 +320,15 @@ The function respects the value of the :exports header argument." (let ((silently (lambda () (let ((session (cdr (assoc :session (nth 2 info))))) (when (not (and session (equal "none" session))) (org-babel-exp-results info type 'silent))))) - (clean (lambda () (unless (eq type 'inline) (org-babel-remove-result info))))) + (clean (lambda () (if (eq type 'inline) + (org-babel-remove-inline-result) + (org-babel-remove-result info))))) (case (intern (or (cdr (assoc :exports (nth 2 info))) "code")) ('none (funcall silently) (funcall clean) "") - ('code (funcall silently) (funcall clean) (org-babel-exp-code info)) + ('code (funcall silently) (funcall clean) (org-babel-exp-code info type)) ('results (org-babel-exp-results info type nil hash) "") ('both (org-babel-exp-results info type nil hash) - (org-babel-exp-code info))))) + (org-babel-exp-code info type))))) (defcustom org-babel-exp-code-template "#+BEGIN_SRC %lang%switches%flags\n%body\n#+END_SRC" @@ -331,7 +350,29 @@ replaced with its value." :group 'org-babel :type 'string) -(defun org-babel-exp-code (info) +(defcustom org-babel-exp-inline-code-template + "src_%lang[%switches%flags]{%body}" + "Template used to export the body of inline code blocks. +This template may be customized to include additional information +such as the code block name, or the values of particular header +arguments. The template is filled out using `org-fill-template', +and the following %keys may be used. + + lang ------ the language of the code block + name ------ the name of the code block + body ------ the body of the code block + switches -- the switches associated to the code block + flags ----- the flags passed to the code block + +In addition to the keys mentioned above, every header argument +defined for the code block may be used as a key and will be +replaced with its value." + :group 'org-babel + :type 'string + :version "25.1" + :package-version '(Org . "8.3")) + +(defun org-babel-exp-code (info type) "Return the original code block formatted for export." (setf (nth 1 info) (if (string= "strip-export" (cdr (assoc :noweb (nth 2 info)))) @@ -339,10 +380,12 @@ replaced with its value." (org-babel-noweb-wrap) "" (nth 1 info)) (if (org-babel-noweb-p (nth 2 info) :export) (org-babel-expand-noweb-references - info (org-babel-exp-get-export-buffer)) + info org-babel-exp-reference-buffer) (nth 1 info)))) (org-fill-template - org-babel-exp-code-template + (if (eq type 'inline) + org-babel-exp-inline-code-template + org-babel-exp-code-template) `(("lang" . ,(nth 0 info)) ("body" . ,(org-escape-code-in-string (nth 1 info))) ("switches" . ,(let ((f (nth 3 info))) @@ -368,7 +411,7 @@ inhibit insertion of results into the buffer." (let ((lang (nth 0 info)) (body (if (org-babel-noweb-p (nth 2 info) :eval) (org-babel-expand-noweb-references - info (org-babel-exp-get-export-buffer)) + info org-babel-exp-reference-buffer) (nth 1 info))) (info (copy-sequence info)) (org-babel-current-src-block-location (point-marker))) diff --git a/lisp/ob-forth.el b/lisp/ob-forth.el new file mode 100644 index 0000000..cc2795a --- /dev/null +++ b/lisp/ob-forth.el @@ -0,0 +1,86 @@ +;;; ob-forth.el --- org-babel functions for Forth + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research, forth +;; Homepage: http://orgmode.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Requires the gforth forth compiler and `forth-mode' (see below). +;; https://www.gnu.org/software/gforth/ + +;;; Requirements: + +;; Session evaluation requires the gforth forth compiler as well as +;; `forth-mode' which is distributed with gforth (in gforth.el). + +;;; Code: +(require 'ob) + +(declare-function forth-proc "ext:gforth" ()) + +(defvar org-babel-default-header-args:forth '((:session . "yes")) + "Default header arguments for forth code blocks.") + +(defun org-babel-execute:forth (body params) + "Execute a block of Forth code with org-babel. +This function is called by `org-babel-execute-src-block'" + (if (string= "none" (cdr (assoc :session params))) + (error "Non-session evaluation not supported for Forth code blocks") + (let ((all-results (org-babel-forth-session-execute body params))) + (if (member "output" (cdr (assoc :result-params params))) + (mapconcat #'identity all-results "\n") + (car (last all-results)))))) + +(defun org-babel-forth-session-execute (body params) + (require 'forth-mode) + (let ((proc (forth-proc)) + (rx " \\(\n:\\|compiled\n\\\|ok\n\\)") + (result-start)) + (with-current-buffer (process-buffer (forth-proc)) + (mapcar (lambda (line) + (setq result-start (progn (goto-char (process-mark proc)) + (point))) + (comint-send-string proc (concat line "\n")) + ;; wait for forth to say "ok" + (while (not (progn (goto-char result-start) + (re-search-forward rx nil t))) + (accept-process-output proc 0.01)) + (let ((case (match-string 1))) + (cond + ((string= "ok\n" case) + ;; Collect intermediate output. + (buffer-substring (+ result-start 1 (length line)) + (match-beginning 0))) + ((string= "compiled\n" case)) + ;; Ignore partial compilation. + ((string= "\n:" case) + ;; Report errors. + (org-babel-eval-error-notify 1 + (buffer-substring + (+ (match-beginning 0) 1) (point-max))) nil)))) + (split-string (org-babel-trim + (org-babel-expand-body:generic + body params)) + "\n" 'omit-nulls))))) + +(provide 'ob-forth) + +;;; ob-forth.el ends here diff --git a/lisp/ob-fortran.el b/lisp/ob-fortran.el index 0211fda..baeb4ba 100644 --- a/lisp/ob-fortran.el +++ b/lisp/ob-fortran.el @@ -33,6 +33,7 @@ (declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) (declare-function org-every "org" (pred seq)) +(declare-function org-remove-indentation "org" (code &optional n)) (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("fortran" . "F90")) @@ -62,8 +63,9 @@ (org-babel-process-file-name tmp-src-file)) "")))) (let ((results (org-babel-trim - (org-babel-eval - (concat tmp-bin-file (if cmdline (concat " " cmdline) "")) "")))) + (org-remove-indentation + (org-babel-eval + (concat tmp-bin-file (if cmdline (concat " " cmdline) "")) ""))))) (org-babel-reassemble-table (org-babel-result-cond (cdr (assoc :result-params params)) (org-babel-read results) diff --git a/lisp/ob-gnuplot.el b/lisp/ob-gnuplot.el index ffe5dcf..a350186 100644 --- a/lisp/ob-gnuplot.el +++ b/lisp/ob-gnuplot.el @@ -64,7 +64,7 @@ (term . :any)) "Gnuplot specific header args.") -(defvar org-babel-gnuplot-timestamp-fmt nil) +(defvar org-babel-gnuplot-timestamp-fmt nil) ; Dynamically scoped. (defvar *org-babel-gnuplot-missing* nil) @@ -118,14 +118,11 @@ code." (timefmt (cdr (assoc :timefmt params))) (time-ind (or (cdr (assoc :timeind params)) (when timefmt 1))) - (missing (cdr (assoc :missing params))) (add-to-body (lambda (text) (setq body (concat text "\n" body)))) output) ;; append header argument settings to body (when title (funcall add-to-body (format "set title '%s'" title))) (when lines (mapc (lambda (el) (funcall add-to-body el)) lines)) - (when missing - (funcall add-to-body (format "set datafile missing '%s'" missing))) (when sets (mapc (lambda (el) (funcall add-to-body (format "set %s" el))) sets)) (when x-labels @@ -267,15 +264,13 @@ then create one. Return the initialized session. The current "Export TABLE to DATA-FILE in a format readable by gnuplot. Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE." (with-temp-file data-file - (make-local-variable 'org-babel-gnuplot-timestamp-fmt) - (setq org-babel-gnuplot-timestamp-fmt (or - (plist-get params :timefmt) - "%Y-%m-%d-%H:%M:%S")) - (insert (orgtbl-to-generic - table - (org-combine-plists - '(:sep "\t" :fmt org-babel-gnuplot-quote-tsv-field) - params)))) + (insert (let ((org-babel-gnuplot-timestamp-fmt + (or (plist-get params :timefmt) "%Y-%m-%d-%H:%M:%S"))) + (orgtbl-to-generic + table + (org-combine-plists + '(:sep "\t" :fmt org-babel-gnuplot-quote-tsv-field) + params))))) data-file) (provide 'ob-gnuplot) diff --git a/lisp/ob-groovy.el b/lisp/ob-groovy.el new file mode 100644 index 0000000..8797ec9 --- /dev/null +++ b/lisp/ob-groovy.el @@ -0,0 +1,118 @@ +;;; ob-groovy.el --- org-babel functions for Groovy evaluation + +;; Copyright (C) 2013-2014 Free Software Foundation, Inc. + +;; Author: Miro Bezjak +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; Currently only supports the external execution. No session support yet. + +;;; Requirements: +;; - Groovy language :: http://groovy.codehaus.org +;; - Groovy major mode :: Can be installed from MELPA or +;; https://github.com/russel/Emacs-Groovy-Mode + +;;; Code: +(require 'ob) +(eval-when-compile (require 'cl)) + +(defvar org-babel-tangle-lang-exts) ;; Autoloaded +(add-to-list 'org-babel-tangle-lang-exts '("groovy" . "groovy")) +(defvar org-babel-default-header-args:groovy '()) +(defcustom org-babel-groovy-command "groovy" + "Name of the command to use for executing Groovy code. +May be either a command in the path, like groovy +or an absolute path name, like /usr/local/bin/groovy +parameters may be used, like groovy -v" + :group 'org-babel + :version "24.3" + :type 'string) + +(defun org-babel-execute:groovy (body params) + "Execute a block of Groovy code with org-babel. This function is +called by `org-babel-execute-src-block'" + (message "executing Groovy source code block") + (let* ((processed-params (org-babel-process-params params)) + (session (org-babel-groovy-initiate-session (nth 0 processed-params))) + (vars (nth 1 processed-params)) + (result-params (nth 2 processed-params)) + (result-type (cdr (assoc :result-type params))) + (full-body (org-babel-expand-body:generic + body params)) + (result (org-babel-groovy-evaluate + session full-body result-type result-params))) + + (org-babel-reassemble-table + result + (org-babel-pick-name + (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) + +(defvar org-babel-groovy-wrapper-method + + "class Runner extends Script { + def out = new PrintWriter(new ByteArrayOutputStream()) + def run() { %s } +} + +println(new Runner().run()) +") + + +(defun org-babel-groovy-evaluate + (session body &optional result-type result-params) + "Evaluate BODY in external Groovy process. +If RESULT-TYPE equals 'output then return standard output as a string. +If RESULT-TYPE equals 'value then return the value of the last statement +in BODY as elisp." + (when session (error "Sessions are not (yet) supported for Groovy")) + (case result-type + (output + (let ((src-file (org-babel-temp-file "groovy-"))) + (progn (with-temp-file src-file (insert body)) + (org-babel-eval + (concat org-babel-groovy-command " " src-file) "")))) + (value + (let* ((src-file (org-babel-temp-file "groovy-")) + (wrapper (format org-babel-groovy-wrapper-method body))) + (with-temp-file src-file (insert wrapper)) + (let ((raw (org-babel-eval + (concat org-babel-groovy-command " " src-file) ""))) + (org-babel-result-cond result-params + raw + (org-babel-script-escape raw))))))) + + +(defun org-babel-prep-session:groovy (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (error "Sessions are not (yet) supported for Groovy")) + +(defun org-babel-groovy-initiate-session (&optional session) + "If there is not a current inferior-process-buffer in SESSION +then create. Return the initialized session. Sessions are not +supported in Groovy." + nil) + +(provide 'ob-groovy) + + + +;;; ob-groovy.el ends here diff --git a/lisp/ob-haskell.el b/lisp/ob-haskell.el index 0006670..2e1d390 100644 --- a/lisp/ob-haskell.el +++ b/lisp/ob-haskell.el @@ -84,7 +84,7 @@ (output (mapconcat #'identity (reverse (cdr results)) "\n")) (value (car results))))) (org-babel-result-cond (cdr (assoc :result-params params)) - result (org-babel-haskell-table-or-string result))) + result (org-babel-script-escape result))) (org-babel-pick-name (cdr (assoc :colname-names params)) (cdr (assoc :colname-names params))) (org-babel-pick-name (cdr (assoc :rowname-names params)) @@ -133,12 +133,6 @@ then create one. Return the initialized session." (org-babel-haskell-var-to-haskell (cdr pair)))) (mapcar #'cdr (org-babel-get-header params :var)))) -(defun org-babel-haskell-table-or-string (results) - "Convert RESULTS to an Emacs-lisp table or string. -If RESULTS look like a table, then convert them into an -Emacs-lisp table, otherwise return the results as a string." - (org-babel-script-escape results)) - (defun org-babel-haskell-var-to-haskell (var) "Convert an elisp value VAR into a haskell variable. The elisp VAR is converted to a string of haskell source code diff --git a/lisp/ob-io.el b/lisp/ob-io.el index 971b37f..c309b88 100644 --- a/lisp/ob-io.el +++ b/lisp/ob-io.el @@ -62,14 +62,6 @@ called by `org-babel-execute-src-block'" (org-babel-pick-name (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) - -(defun org-babel-io-table-or-string (results) - "Convert RESULTS into an appropriate elisp value. -If RESULTS look like a table, then convert them into an -Emacs-lisp table, otherwise return the results as a string." - (org-babel-script-escape results)) - - (defvar org-babel-io-wrapper-method "( %s @@ -98,7 +90,7 @@ in BODY as elisp." (concat org-babel-io-command " " src-file) ""))) (org-babel-result-cond result-params raw - (org-babel-io-table-or-string raw))))))) + (org-babel-script-escape raw))))))) (defun org-babel-prep-session:io (session params) diff --git a/lisp/ob-java.el b/lisp/ob-java.el index 22f8785..8c64171 100644 --- a/lisp/ob-java.el +++ b/lisp/ob-java.el @@ -32,11 +32,23 @@ (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("java" . "java")) -(defvar org-babel-java-command "java" - "Name of the java command.") - -(defvar org-babel-java-compiler "javac" - "Name of the java compiler.") +(defcustom org-babel-java-command "java" + "Name of the java command. +May be either a command in the path, like java +or an absolute path name, like /usr/local/bin/java +parameters may be used, like java -verbose" + :group 'org-babel + :version "24.3" + :type 'string) + +(defcustom org-babel-java-compiler "javac" + "Name of the java compiler. +May be either a command in the path, like javac +or an absolute path name, like /usr/local/bin/javac +parameters may be used, like javac -verbose" + :group 'org-babel + :version "24.3" + :type 'string) (defun org-babel-execute:java (body params) (let* ((classname (or (cdr (assoc :classname params)) diff --git a/lisp/ob-js.el b/lisp/ob-js.el index 7789449..e126787 100644 --- a/lisp/ob-js.el +++ b/lisp/ob-js.el @@ -97,14 +97,15 @@ This function is called by `org-babel-execute-src-block'" If RESULTS look like a table, then convert them into an Emacs-lisp table, otherwise return the results as a string." (org-babel-read - (if (and (stringp results) (string-match "^\\[.+\\]$" results)) + (if (and (stringp results) (string-match "^\\[[^\000]+\\]$" results)) (org-babel-read (concat "'" (replace-regexp-in-string "\\[" "(" (replace-regexp-in-string "\\]" ")" (replace-regexp-in-string - ", " " " (replace-regexp-in-string - "'" "\"" results)))))) + ",[[:space:]]" " " + (replace-regexp-in-string + "'" "\"" results)))))) results))) (defun org-babel-js-var-to-js (var) @@ -113,7 +114,7 @@ Convert an elisp value into a string of js source code specifying a variable of the same value." (if (listp var) (concat "[" (mapconcat #'org-babel-js-var-to-js var ", ") "]") - (format "%S" var))) + (replace-regexp-in-string "\n" "\\\\n" (format "%S" var)))) (defun org-babel-prep-session:js (session params) "Prepare SESSION according to the header arguments specified in PARAMS." diff --git a/lisp/ob-keys.el b/lisp/ob-keys.el index 90b5196..dc1f437 100644 --- a/lisp/ob-keys.el +++ b/lisp/ob-keys.el @@ -89,6 +89,7 @@ functions which are assigned key bindings, and see ("h" . org-babel-describe-bindings) ("\C-x" . org-babel-do-key-sequence-in-edit-buffer) ("x" . org-babel-do-key-sequence-in-edit-buffer) + ("k" . org-babel-remove-result-one-or-many) ("\C-\M-h" . org-babel-mark-block)) "Alist of key bindings and interactive Babel functions. This list associates interactive Babel functions diff --git a/lisp/ob-latex.el b/lisp/ob-latex.el index 35b6650..4efa78d 100644 --- a/lisp/ob-latex.el +++ b/lisp/ob-latex.el @@ -50,7 +50,18 @@ '((:results . "latex") (:exports . "results")) "Default arguments to use when evaluating a LaTeX source block.") -(defcustom org-babel-latex-htlatex "" +(defconst org-babel-header-args:latex + '((border . :any) + (fit . :any) + (iminoptions . :any) + (imoutoptions . :any) + (packages . :any) + (pdfheight . :any) + (pdfpng . :any) + (pdfwidth . :any)) + "LaTeX-specific header arguments.") + +(defcustom org-babel-latex-htlatex "htlatex" "The htlatex command to enable conversion of latex to SVG or HTML." :group 'org-babel :type 'string) @@ -99,6 +110,51 @@ This function is called by `org-babel-execute-src-block'." (when (file-exists-p out-file) (delete-file out-file)) (with-temp-file out-file (insert body))) + ((and (or (string-match "\\.svg$" out-file) + (string-match "\\.html$" out-file)) + (executable-find org-babel-latex-htlatex)) + ;; TODO: this is a very different way of generating the + ;; frame latex document than in the pdf case. Ideally, both + ;; would be unified. This would prevent bugs creeping in + ;; such as the one fixed on Aug 16 2014 whereby :headers was + ;; not included in the SVG/HTML case. + (with-temp-file tex-file + (insert (concat + "\\documentclass[preview]{standalone} +\\def\\pgfsysdriver{pgfsys-tex4ht.def} +" + (mapconcat (lambda (pkg) + (concat "\\usepackage" pkg)) + org-babel-latex-htlatex-packages + "\n") + (if headers + (concat "\n" + (if (listp headers) + (mapconcat #'identity headers "\n") + headers) "\n") + "") + "\\begin{document}" + body + "\\end{document}"))) + (when (file-exists-p out-file) (delete-file out-file)) + (let ((default-directory (file-name-directory tex-file))) + (shell-command (format "%s %s" org-babel-latex-htlatex tex-file))) + (cond + ((file-exists-p (concat (file-name-sans-extension tex-file) "-1.svg")) + (if (string-match "\\.svg$" out-file) + (progn + (shell-command "pwd") + (shell-command (format "mv %s %s" + (concat (file-name-sans-extension tex-file) "-1.svg") + out-file))) + (error "SVG file produced but HTML file requested"))) + ((file-exists-p (concat (file-name-sans-extension tex-file) ".html")) + (if (string-match "\\.html$" out-file) + (shell-command "mv %s %s" + (concat (file-name-sans-extension tex-file) + ".html") + out-file) + (error "HTML file produced but SVG file requested"))))) ((or (string-match "\\.pdf$" out-file) imagemagick) (with-temp-file tex-file (require 'ox-latex) @@ -135,51 +191,17 @@ This function is called by `org-babel-execute-src-block'." ((string-match "\\.pdf$" out-file) (rename-file transient-pdf-file out-file)) (imagemagick - (convert-pdf + (org-babel-latex-convert-pdf transient-pdf-file out-file im-in-options im-out-options) (when (file-exists-p transient-pdf-file) (delete-file transient-pdf-file)))))) - ((and (or (string-match "\\.svg$" out-file) - (string-match "\\.html$" out-file)) - (not (string= "" org-babel-latex-htlatex))) - (with-temp-file tex-file - (insert (concat - "\\documentclass[preview]{standalone} -\\def\\pgfsysdriver{pgfsys-tex4ht.def} -" - (mapconcat (lambda (pkg) - (concat "\\usepackage" pkg)) - org-babel-latex-htlatex-packages - "\n") - "\\begin{document}" - body - "\\end{document}"))) - (when (file-exists-p out-file) (delete-file out-file)) - (let ((default-directory (file-name-directory tex-file))) - (shell-command (format "%s %s" org-babel-latex-htlatex tex-file))) - (cond - ((file-exists-p (concat (file-name-sans-extension tex-file) "-1.svg")) - (if (string-match "\\.svg$" out-file) - (progn - (shell-command "pwd") - (shell-command (format "mv %s %s" - (concat (file-name-sans-extension tex-file) "-1.svg") - out-file))) - (error "SVG file produced but HTML file requested."))) - ((file-exists-p (concat (file-name-sans-extension tex-file) ".html")) - (if (string-match "\\.html$" out-file) - (shell-command "mv %s %s" - (concat (file-name-sans-extension tex-file) - ".html") - out-file) - (error "HTML file produced but SVG file requested."))))) ((string-match "\\.\\([^\\.]+\\)$" out-file) (error "Can not create %s files, please specify a .png or .pdf file or try the :imagemagick header argument" (match-string 1 out-file)))) nil) ;; signal that output has already been written to file body)) -(defun convert-pdf (pdffile out-file im-in-options im-out-options) +(defun org-babel-latex-convert-pdf (pdffile out-file im-in-options im-out-options) "Generate a file from a pdf file using imagemagick." (let ((cmd (concat "convert " im-in-options " " pdffile " " im-out-options " " out-file))) diff --git a/lisp/ob-lilypond.el b/lisp/ob-lilypond.el index 00a951d..c7ad576 100644 --- a/lisp/ob-lilypond.el +++ b/lisp/ob-lilypond.el @@ -28,6 +28,8 @@ ;; ;; Lilypond documentation can be found at ;; http://lilypond.org/manuals.html +;; +;; This depends on epstopdf --- See http://www.ctan.org/pkg/epstopdf. ;;; Code: (require 'ob) @@ -60,47 +62,64 @@ org-babel-lilypond-play-midi-post-tangle determines whether to automate the playing of the resultant midi file. If the value is nil, the midi file is not automatically played. Default value is t") -(defvar org-babel-lilypond-OSX-ly-path - "/Applications/lilypond.app/Contents/Resources/bin/lilypond") -(defvar org-babel-lilypond-OSX-pdf-path "open") -(defvar org-babel-lilypond-OSX-midi-path "open") - -(defvar org-babel-lilypond-nix-ly-path "/usr/bin/lilypond") -(defvar org-babel-lilypond-nix-pdf-path "evince") -(defvar org-babel-lilypond-nix-midi-path "timidity") - -(defvar org-babel-lilypond-w32-ly-path "lilypond") -(defvar org-babel-lilypond-w32-pdf-path "") -(defvar org-babel-lilypond-w32-midi-path "") +(defvar org-babel-lilypond-ly-command "" + "Command to execute lilypond on your system. +Do not set it directly. Customize `org-babel-lilypond-commands' instead.") +(defvar org-babel-lilypond-pdf-command "" + "Command to show a PDF file on your system. +Do not set it directly. Customize `org-babel-lilypond-commands' instead.") +(defvar org-babel-lilypond-midi-command "" + "Command to play a MIDI file on your system. +Do not set it directly. Customize `org-babel-lilypond-commands' instead.") +(defcustom org-babel-lilypond-commands + (cond + ((eq system-type 'darwin) + '("/Applications/lilypond.app/Contents/Resources/bin/lilypond" "open" "open")) + ((eq system-type 'windows-nt) + '("lilypond" "" "")) + (t + '("lilypond" "xdg-open" "xdg-open"))) + "Commands to run lilypond and view or play the results. +These should be executables that take a filename as an argument. +On some system it is possible to specify the filename directly +and the viewer or player will be determined from the file type; +you can leave the string empty on this case." + :group 'org-babel + :type '(list + (string :tag "Lilypond ") + (string :tag "PDF Viewer ") + (string :tag "MIDI Player")) + :version "24.3" + :package-version '(Org . "8.2.7") + :set + (lambda (symbol value) + (setq + org-babel-lilypond-ly-command (nth 0 value) + org-babel-lilypond-pdf-command (nth 1 value) + org-babel-lilypond-midi-command (nth 2 value)))) (defvar org-babel-lilypond-gen-png nil - "Image generation (png) can be turned on by default by setting -ORG-BABEL-LILYPOND-GEN-PNG to t") + "Non-nil means image generation (PNG) is turned on by default.") (defvar org-babel-lilypond-gen-svg nil - "Image generation (SVG) can be turned on by default by setting -ORG-BABEL-LILYPOND-GEN-SVG to t") + "Non-nil means image generation (SVG) is be turned on by default.") (defvar org-babel-lilypond-gen-html nil - "HTML generation can be turned on by default by setting -ORG-BABEL-LILYPOND-GEN-HTML to t") + "Non-nil means HTML generation is turned on by default.") (defvar org-babel-lilypond-gen-pdf nil - "PDF generation can be turned on by default by setting -ORG-BABEL-LILYPOND-GEN-PDF to t") + "Non-nil means PDF generation is be turned on by default.") (defvar org-babel-lilypond-use-eps nil - "You can force the compiler to use the EPS backend by setting -ORG-BABEL-LILYPOND-USE-EPS to t") + "Non-nil forces the compiler to use the EPS backend.") (defvar org-babel-lilypond-arrange-mode nil - "Arrange mode is turned on by setting ORG-BABEL-LILYPOND-ARRANGE-MODE -to t. In Arrange mode the following settings are altered -from default... + "Non-nil turns Arrange mode on. +In Arrange mode the following settings are altered from default: :tangle yes, :noweb yes :results silent :comments yes. In addition lilypond block execution causes tangling of all lilypond -blocks") +blocks.") (defun org-babel-expand-body:lilypond (body params) "Expand BODY according to PARAMS, return the expanded body." @@ -148,7 +167,7 @@ specific arguments to =org-babel-tangle=" (insert (org-babel-expand-body:generic body params))) (org-babel-eval (concat - (org-babel-lilypond-determine-ly-path) + org-babel-lilypond-ly-command " -dbackend=eps " "-dno-gs-load-fonts " "-dinclude-eps-fonts " @@ -175,29 +194,27 @@ If error in compilation, attempt to mark the error in lilypond org file" (buffer-file-name) ".lilypond")) (org-babel-lilypond-temp-file (org-babel-lilypond-switch-extension (buffer-file-name) ".ly"))) - (if (file-exists-p org-babel-lilypond-tangled-file) - (progn - (when (file-exists-p org-babel-lilypond-temp-file) - (delete-file org-babel-lilypond-temp-file)) - (rename-file org-babel-lilypond-tangled-file - org-babel-lilypond-temp-file)) - (error "Error: Tangle Failed!") t) + (if (not (file-exists-p org-babel-lilypond-tangled-file)) + (error "Error: Tangle Failed!") + (when (file-exists-p org-babel-lilypond-temp-file) + (delete-file org-babel-lilypond-temp-file)) + (rename-file org-babel-lilypond-tangled-file + org-babel-lilypond-temp-file)) (switch-to-buffer-other-window "*lilypond*") (erase-buffer) (org-babel-lilypond-compile-lilyfile org-babel-lilypond-temp-file) (goto-char (point-min)) - (if (not (org-babel-lilypond-check-for-compile-error org-babel-lilypond-temp-file)) - (progn - (other-window -1) - (org-babel-lilypond-attempt-to-open-pdf org-babel-lilypond-temp-file) - (org-babel-lilypond-attempt-to-play-midi org-babel-lilypond-temp-file)) - (error "Error in Compilation!")))) nil) + (if (org-babel-lilypond-check-for-compile-error org-babel-lilypond-temp-file) + (error "Error in Compilation!") + (other-window -1) + (org-babel-lilypond-attempt-to-open-pdf org-babel-lilypond-temp-file) + (org-babel-lilypond-attempt-to-play-midi org-babel-lilypond-temp-file))))) (defun org-babel-lilypond-compile-lilyfile (file-name &optional test) "Compile lilypond file and check for compile errors FILE-NAME is full path to lilypond (.ly) file" (message "Compiling LilyPond...") - (let ((arg-1 (org-babel-lilypond-determine-ly-path)) ;program + (let ((arg-1 org-babel-lilypond-ly-command) ;program (arg-2 nil) ;infile (arg-3 "*lilypond*") ;buffer (arg-4 t) ;display @@ -223,11 +240,10 @@ FILE-NAME is full path to lilypond file. If TEST is t just return nil if no error found, and pass nil as file-name since it is unused in this context" (let ((is-error (search-forward "error:" nil t))) - (if (not test) - (if (not is-error) - nil - (org-babel-lilypond-process-compile-error file-name)) - is-error))) + (if test + is-error + (when is-error + (org-babel-lilypond-process-compile-error file-name))))) (defun org-babel-lilypond-process-compile-error (file-name) "Process the compilation error that has occurred. @@ -298,13 +314,13 @@ If TEST is non-nil, the shell command is returned and is not run" (let ((pdf-file (org-babel-lilypond-switch-extension file-name ".pdf"))) (if (file-exists-p pdf-file) (let ((cmd-string - (concat (org-babel-lilypond-determine-pdf-path) " " pdf-file))) + (concat org-babel-lilypond-pdf-command " " pdf-file))) (if test cmd-string (start-process "\"Audition pdf\"" "*lilypond*" - (org-babel-lilypond-determine-pdf-path) + org-babel-lilypond-pdf-command pdf-file))) (message "No pdf file generated so can't display!"))))) @@ -316,49 +332,16 @@ If TEST is non-nil, the shell command is returned and is not run" (let ((midi-file (org-babel-lilypond-switch-extension file-name ".midi"))) (if (file-exists-p midi-file) (let ((cmd-string - (concat (org-babel-lilypond-determine-midi-path) " " midi-file))) + (concat org-babel-lilypond-midi-command " " midi-file))) (if test cmd-string (start-process "\"Audition midi\"" "*lilypond*" - (org-babel-lilypond-determine-midi-path) + org-babel-lilypond-midi-command midi-file))) (message "No midi file generated so can't play!"))))) -(defun org-babel-lilypond-determine-ly-path (&optional test) - "Return correct path to ly binary depending on OS -If TEST is non-nil, it contains a simulation of the OS for test purposes" - (let ((sys-type - (or test system-type))) - (cond ((string= sys-type "darwin") - org-babel-lilypond-OSX-ly-path) - ((string= sys-type "windows-nt") - org-babel-lilypond-w32-ly-path) - (t org-babel-lilypond-nix-ly-path)))) - -(defun org-babel-lilypond-determine-pdf-path (&optional test) - "Return correct path to pdf viewer depending on OS -If TEST is non-nil, it contains a simulation of the OS for test purposes" - (let ((sys-type - (or test system-type))) - (cond ((string= sys-type "darwin") - org-babel-lilypond-OSX-pdf-path) - ((string= sys-type "windows-nt") - org-babel-lilypond-w32-pdf-path) - (t org-babel-lilypond-nix-pdf-path)))) - -(defun org-babel-lilypond-determine-midi-path (&optional test) - "Return correct path to midi player depending on OS -If TEST is non-nil, it contains a simulation of the OS for test purposes" - (let ((sys-type - (or test test system-type))) - (cond ((string= sys-type "darwin") - org-babel-lilypond-OSX-midi-path) - ((string= sys-type "windows-nt") - org-babel-lilypond-w32-midi-path) - (t org-babel-lilypond-nix-midi-path)))) - (defun org-babel-lilypond-toggle-midi-play () "Toggle whether midi will be played following a successful compilation." (interactive) diff --git a/lisp/ob-lisp.el b/lisp/ob-lisp.el index 6bddd61..a59dab3 100644 --- a/lisp/ob-lisp.el +++ b/lisp/ob-lisp.el @@ -44,7 +44,7 @@ (defvar org-babel-header-args:lisp '((package . :any))) (defcustom org-babel-lisp-dir-fmt - "(let ((*default-pathname-defaults* #P%S)) %%s)" + "(let ((*default-pathname-defaults* #P%S\n)) %%s\n)" "Format string used to wrap code bodies to set the current directory. For example a value of \"(progn ;; %s\\n %%s)\" would ignore the current directory string." @@ -76,23 +76,25 @@ current directory string." (require 'slime) (org-babel-reassemble-table (let ((result - (with-temp-buffer - (insert (org-babel-expand-body:lisp body params)) - (slime-eval `(swank:eval-and-grab-output - ,(let ((dir (if (assoc :dir params) - (cdr (assoc :dir params)) - default-directory))) - (format - (if dir (format org-babel-lisp-dir-fmt dir) - "(progn %s)") - (buffer-substring-no-properties - (point-min) (point-max))))) - (cdr (assoc :package params)))))) + (funcall (if (member "output" (cdr (assoc :result-params params))) + #'car #'cadr) + (with-temp-buffer + (insert (org-babel-expand-body:lisp body params)) + (slime-eval `(swank:eval-and-grab-output + ,(let ((dir (if (assoc :dir params) + (cdr (assoc :dir params)) + default-directory))) + (format + (if dir (format org-babel-lisp-dir-fmt dir) + "(progn %s\n)") + (buffer-substring-no-properties + (point-min) (point-max))))) + (cdr (assoc :package params))))))) (org-babel-result-cond (cdr (assoc :result-params params)) - (car result) + result (condition-case nil - (read (org-babel-lisp-vector-to-list (cadr result))) - (error (cadr result))))) + (read (org-babel-lisp-vector-to-list result)) + (error result)))) (org-babel-pick-name (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) (org-babel-pick-name (cdr (assoc :rowname-names params)) diff --git a/lisp/ob-lob.el b/lisp/ob-lob.el index 4e635da..0267f44 100644 --- a/lisp/ob-lob.el +++ b/lisp/ob-lob.el @@ -1,6 +1,6 @@ ;;; ob-lob.el --- functions supporting the Library of Babel -;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Authors: Eric Schulte ;; Dan Davison @@ -70,8 +70,8 @@ To add files to this list use the `org-babel-lob-ingest' command." (defconst org-babel-inline-lob-one-liner-regexp (concat - "\\([^\n]*?\\)call_\\([^\(\)\n]+?\\)\\(\\[\\(.*?\\)\\]\\|\\(\\)\\)" - "\(\\([^\n]*?\\)\)\\(\\[\\(.*?\\)\\]\\)?") + "\\([^\n]*?\\)call_\\([^\(\)[:space:]\n]+?\\)\\(\\[\\(.*?\\)\\]\\|\\(\\)\\)" + "\(\\(.*?\\)\)\\(\\[\\(.*?\\)\\]\\)?") "Regexp to match inline calls to predefined source block functions.") (defconst org-babel-lob-one-liner-regexp @@ -116,9 +116,10 @@ if so then run the appropriate source block from the Library." (match-string 2) (match-string 11))) (save-excursion (forward-line -1) - (and (looking-at (concat org-babel-src-name-regexp - "\\([^\n]*\\)$")) - (org-no-properties (match-string 1)))))))))) + (save-match-data + (and (looking-at (concat org-babel-src-name-regexp + "\\([^\n]*\\)$")) + (org-no-properties (match-string 1))))))))))) (defvar org-babel-default-header-args:emacs-lisp) ; Defined in ob-emacs-lisp.el (defun org-babel-lob-execute (info) @@ -142,18 +143,32 @@ if so then run the appropriate source block from the Library." (pre-info (funcall mkinfo pre-params)) (cache-p (and (cdr (assoc :cache pre-params)) (string= "yes" (cdr (assoc :cache pre-params))))) - (new-hash (when cache-p (org-babel-sha1-hash pre-info))) - (old-hash (when cache-p (org-babel-current-result-hash))) + (new-hash (when cache-p + (org-babel-sha1-hash + ;; Do *not* pre-process params for call line + ;; hash evaluation, since for a call line :var + ;; extension *is* execution. + (let* ((params (nth 2 pre-info)) + (sha1-nth2 (list + (cons + (cons :c-var (cdr (assoc :var params))) + (assq-delete-all :var (copy-tree params))))) + (sha1-info (copy-tree pre-info))) + (prog1 sha1-info + (setcar (cddr sha1-info) sha1-nth2)))))) + (old-hash (when cache-p (org-babel-current-result-hash pre-info))) (org-babel-current-src-block-location (point-marker))) (if (and cache-p (equal new-hash old-hash)) - (save-excursion (goto-char (org-babel-where-is-src-block-result)) + (save-excursion (goto-char (org-babel-where-is-src-block-result + nil pre-info)) (forward-line 1) (message "%S" (org-babel-read-result))) (prog1 (let* ((proc-params (org-babel-process-params pre-params)) org-confirm-babel-evaluate) (org-babel-execute-src-block nil (funcall mkinfo proc-params))) ;; update the hash - (when new-hash (org-babel-set-current-result-hash new-hash)))))) + (when new-hash + (org-babel-set-current-result-hash new-hash pre-info)))))) (provide 'ob-lob) diff --git a/lisp/ob-maxima.el b/lisp/ob-maxima.el index 7435f1d..4e559d1 100644 --- a/lisp/ob-maxima.el +++ b/lisp/ob-maxima.el @@ -52,7 +52,7 @@ (mapconcat 'identity (list ;; graphic output - (let ((graphic-file (org-babel-maxima-graphical-output-file params))) + (let ((graphic-file (ignore-errors (org-babel-graphical-output-file params)))) (if graphic-file (format "set_plot_option ([gnuplot_term, png]); set_plot_option ([gnuplot_out_file, %S]);" @@ -89,7 +89,7 @@ This function is called by `org-babel-execute-src-block'." (= 0 (length line))) line)) (split-string raw "[\r\n]"))) "\n"))))) - (if (org-babel-maxima-graphical-output-file params) + (if (ignore-errors (org-babel-graphical-output-file params)) nil (org-babel-result-cond result-params result @@ -113,11 +113,6 @@ of the same value." (format "%S: %s$" var (org-babel-maxima-elisp-to-maxima val)))) -(defun org-babel-maxima-graphical-output-file (params) - "Name of file to which maxima should send graphical output." - (and (member "graphics" (cdr (assq :result-params params))) - (cdr (assq :file params)))) - (defun org-babel-maxima-elisp-to-maxima (val) "Return a string of maxima code which evaluates to VAL." (if (listp val) diff --git a/lisp/ob-ocaml.el b/lisp/ob-ocaml.el index 1f29a25..9cd72b3 100644 --- a/lisp/ob-ocaml.el +++ b/lisp/ob-ocaml.el @@ -1,6 +1,6 @@ ;;; ob-ocaml.el --- org-babel functions for ocaml evaluation -;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Author: Eric Schulte ;; Keywords: literate programming, reproducible research @@ -70,7 +70,8 @@ (session org-babel-ocaml-eoe-output t full-body) (insert (concat - (org-babel-chomp full-body)";;\n"org-babel-ocaml-eoe-indicator)) + (org-babel-chomp full-body) ";;\n" + org-babel-ocaml-eoe-indicator)) (tuareg-interactive-send-input))) (clean (car (let ((re (regexp-quote org-babel-ocaml-eoe-output)) out) @@ -79,16 +80,25 @@ (progn (setq out nil) line) (when (string-match re line) (progn (setq out t) nil)))) - (mapcar #'org-babel-trim (reverse raw)))))))) + (mapcar #'org-babel-trim (reverse raw))))))) + (raw (org-babel-trim clean)) + (result-params (cdr (assoc :result-params params))) + (parsed + (string-match + "\\(\\(.*\n\\)*\\)[^:\n]+ : \\([^=\n]+\\) =\\(\n\\| \\)\\(.+\\)$" + raw)) + (output (match-string 1 raw)) + (type (match-string 3 raw)) + (value (match-string 5 raw))) (org-babel-reassemble-table - (let ((raw (org-babel-trim clean)) - (result-params (cdr (assoc :result-params params)))) - (org-babel-result-cond result-params - ;; strip type information from output unless verbatim is specified - (if (and (not (member "verbatim" result-params)) - (string-match "= \\(.+\\)$" raw)) - (match-string 1 raw) raw) - (org-babel-ocaml-parse-output raw))) + (org-babel-result-cond result-params + (cond + ((member "verbatim" result-params) raw) + ((member "output" result-params) output) + (t raw)) + (if (and value type) + (org-babel-ocaml-parse-output value type) + raw)) (org-babel-pick-name (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) (org-babel-pick-name @@ -121,26 +131,29 @@ (concat "[|" (mapconcat #'org-babel-ocaml-elisp-to-ocaml val "; ") "|]") (format "%S" val))) -(defun org-babel-ocaml-parse-output (output) - "Parse OUTPUT. -OUTPUT is string output from an ocaml process." - (let ((regexp "[^:]+ : %s = \\(.+\\)$")) - (cond - ((string-match (format regexp "string") output) - (org-babel-read (match-string 1 output))) - ((or (string-match (format regexp "int") output) - (string-match (format regexp "float") output)) - (string-to-number (match-string 1 output))) - ((string-match (format regexp "list") output) - (org-babel-ocaml-read-list (match-string 1 output))) - ((string-match (format regexp "array") output) - (org-babel-ocaml-read-array (match-string 1 output))) - (t (message "don't recognize type of %s" output) output)))) +(defun org-babel-ocaml-parse-output (value type) + "Parse VALUE of type TYPE. +VALUE and TYPE are string output from an ocaml process." + (cond + ((string= "string" type) + (org-babel-read value)) + ((or (string= "int" type) + (string= "float" type)) + (string-to-number value)) + ((string-match "list" type) + (org-babel-ocaml-read-list value)) + ((string-match "array" type) + (org-babel-ocaml-read-array value)) + (t (message "don't recognize type %s" type) value))) (defun org-babel-ocaml-read-list (results) "Convert RESULTS into an elisp table or string. If the results look like a table, then convert them into an Emacs-lisp table, otherwise return the results as a string." + ;; XXX: This probably does not behave as expected when a semicolon + ;; is in a string in a list. The same comment applies to + ;; `org-babel-ocaml-read-array' below (with even more failure + ;; modes). (org-babel-script-escape (replace-regexp-in-string ";" "," results))) (defun org-babel-ocaml-read-array (results) diff --git a/lisp/ob-octave.el b/lisp/ob-octave.el index 8cc66b6..14b55d2 100644 --- a/lisp/ob-octave.el +++ b/lisp/ob-octave.el @@ -82,18 +82,19 @@ end") (full-body (org-babel-expand-body:generic body params (org-babel-variable-assignments:octave params))) + (gfx-file (ignore-errors (org-babel-graphical-output-file params))) (result (org-babel-octave-evaluate session - (if (org-babel-octave-graphical-output-file params) + (if gfx-file (mapconcat 'identity (list "set (0, \"defaultfigurevisible\", \"off\");" full-body - (format "print -dpng %s" (org-babel-octave-graphical-output-file params))) + (format "print -dpng %s" gfx-file)) "\n") full-body) result-type matlabp))) - (if (org-babel-octave-graphical-output-file params) + (if gfx-file nil (org-babel-reassemble-table result @@ -268,11 +269,6 @@ This removes initial blank and comment lines and then calls (match-string 1 string) string)) -(defun org-babel-octave-graphical-output-file (params) - "Name of file to which maxima should send graphical output." - (and (member "graphics" (cdr (assq :result-params params))) - (cdr (assq :file params)))) - (provide 'ob-octave) diff --git a/lisp/ob-processing.el b/lisp/ob-processing.el new file mode 100644 index 0000000..d983afe --- /dev/null +++ b/lisp/ob-processing.el @@ -0,0 +1,197 @@ +;;; ob-processing.el --- Babel functions for evaluation of processing + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Jarmo Hurri (adapted from ob-asymptote.el written by Eric Schulte) +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Babel support for evaluating processing source code. +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in processing +;; +;; 2) results can only be exported as html; in this case, the +;; processing code is embedded via a file into a javascript block +;; using the processing.js module; the script then draws the +;; resulting output when the web page is viewed in a browser; note +;; that the user is responsible for making sure that processing.js +;; is available on the website +;; +;; 3) it is possible to interactively view the sketch of the +;; Processing code block via Processing 2.0 Emacs mode, using +;; `org-babel-processing-view-sketch'. You can bind this command +;; to, e.g., C-c C-v C-k with +;; +;; (define-key org-babel-map (kbd "C-k") 'org-babel-processing-view-sketch) + + +;;; Requirements: + +;; - processing2-emacs mode :: https://github.com/ptrv/processing2-emacs +;; - Processing.js module :: http://processingjs.org/ + +;;; Code: +(require 'ob) +(require 'sha1) +(eval-when-compile (require 'cl)) + +(declare-function processing-sketch-run "ext:processing-mode" ()) + +(defvar org-babel-temporary-directory) + +(defvar org-babel-tangle-lang-exts) +(add-to-list 'org-babel-tangle-lang-exts '("processing" . "pde")) + +;; Default header tags depend on whether exporting html or not; if not +;; exporting html, then no results are produced; otherwise results are +;; HTML. +(defvar org-babel-default-header-args:processing + '((:results . "html") (:exports . "results")) + "Default arguments when evaluating a Processing source block.") + +(defvar org-babel-processing-processing-js-filename "processing.js" + "Filename of the processing.js file.") + +(defun org-babel-processing-view-sketch () + "Show the sketch of the Processing block under point in an external viewer." + (interactive) + (require 'processing-mode) + (let ((info (org-babel-get-src-block-info))) + (if (string= (nth 0 info) "processing") + (let* ((body (nth 1 info)) + (params (org-babel-process-params (nth 2 info))) + (sketch-code + (org-babel-expand-body:generic + body + params + (org-babel-variable-assignments:processing params)))) + ;; Note: sketch filename can not contain a hyphen, since it + ;; has to be a valid java class name; for this reason + ;; make-temp-file is repeated until no hyphen is in the + ;; name; also sketch dir name must be the same as the + ;; basename of the sketch file. + (let* ((temporary-file-directory org-babel-temporary-directory) + (sketch-dir + (let (sketch-dir-candidate) + (while + (progn + (setq sketch-dir-candidate + (make-temp-file "processing" t)) + (when (org-string-match-p + "-" + (file-name-nondirectory sketch-dir-candidate)) + (delete-directory sketch-dir-candidate) + t))) + sketch-dir-candidate)) + (sketch-filename + (concat sketch-dir + "/" + (file-name-nondirectory sketch-dir) + ".pde"))) + (with-temp-file sketch-filename (insert sketch-code)) + (find-file sketch-filename) + (processing-sketch-run) + (kill-buffer))) + (message "Not inside a Processing source block.")))) + +(defun org-babel-execute:processing (body params) + "Execute a block of Processing code. +This function is called by `org-babel-execute-src-block'." + (let ((sketch-code + (org-babel-expand-body:generic + body + params + (org-babel-variable-assignments:processing params)))) + ;; Results are HTML. + (let ((sketch-canvas-id (concat "ob-" (sha1 sketch-code)))) + (concat "<script src=\"" + org-babel-processing-processing-js-filename + "\"></script>\n <script type=\"text/processing\"" + " data-processing-target=\"" + sketch-canvas-id + "\">\n" + sketch-code + "\n</script> <canvas id=\"" + sketch-canvas-id + "\"></canvas>")))) + +(defun org-babel-prep-session:processing (session params) + "Return an error if the :session header argument is set. +Processing does not support sessions" + (error "Processing does not support sessions")) + +(defun org-babel-variable-assignments:processing (params) + "Return list of processing statements assigning the block's variables." + (mapcar #'org-babel-processing-var-to-processing + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-processing-var-to-processing (pair) + "Convert an elisp value into a Processing variable. +The elisp value PAIR is converted into Processing code specifying +a variable of the same value." + (let ((var (car pair)) + (val (let ((v (cdr pair))) + (if (symbolp v) (symbol-name v) v)))) + (cond + ((integerp val) + (format "int %S=%S;" var val)) + ((floatp val) + (format "float %S=%S;" var val)) + ((stringp val) + (format "String %S=\"%s\";" var val)) + ((and (listp val) (not (listp (car val)))) + (let* ((type (org-babel-processing-define-type val)) + (fmt (if (eq 'String type) "\"%s\"" "%s")) + (vect (mapconcat (lambda (e) (format fmt e)) val ", "))) + (format "%s[] %S={%s};" type var vect))) + ((listp val) + (let* ((type (org-babel-processing-define-type val)) + (fmt (if (eq 'String type) "\"%s\"" "%s")) + (array (mapconcat (lambda (row) + (concat "{" + (mapconcat (lambda (e) (format fmt e)) + row ", ") + "}")) + val ","))) + (format "%S[][] %S={%s};" type var array)))))) + +(defun org-babel-processing-define-type (data) + "Determine type of DATA. + +DATA is a list. Return type as a symbol. + +The type is `String' if any element in DATA is +a string. Otherwise, it is either `float', if some elements are +floats, or `int'." + (let* ((type 'int) + find-type ; For byte-compiler. + (find-type + (lambda (row) + (dolist (e row type) + (cond ((listp e) (setq type (funcall find-type e))) + ((stringp e) (throw 'exit 'String)) + ((floatp e) (setq type 'float))))))) + (catch 'exit (funcall find-type data)))) + +(provide 'ob-processing) + +;;; ob-processing.el ends here diff --git a/lisp/ob-python.el b/lisp/ob-python.el index 7cee104..dd3cc66 100644 --- a/lisp/ob-python.el +++ b/lisp/ob-python.el @@ -1,6 +1,6 @@ ;;; ob-python.el --- org-babel functions for python evaluation -;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Authors: Eric Schulte ;; Dan Davison @@ -80,6 +80,8 @@ This function is called by `org-babel-execute-src-block'." (return-val (when (and (eq result-type 'value) (not session)) (cdr (assoc :return params)))) (preamble (cdr (assoc :preamble params))) + (org-babel-python-command + (or (cdr (assoc :python params)) org-babel-python-command)) (full-body (org-babel-expand-body:generic (concat body (if return-val (format "\nreturn %s" return-val) "")) @@ -222,13 +224,13 @@ then create. Return the initialized session." (defvar org-babel-python-eoe-indicator "'org_babel_python_eoe'" "A string to indicate that evaluation has completed.") -(defvar org-babel-python-wrapper-method +(defconst org-babel-python-wrapper-method " def main(): %s open('%s', 'w').write( str(main()) )") -(defvar org-babel-python-pp-wrapper-method +(defconst org-babel-python-pp-wrapper-method " import pprint def main(): diff --git a/lisp/ob-ref.el b/lisp/ob-ref.el index 152af86..b8a921e 100644 --- a/lisp/ob-ref.el +++ b/lisp/ob-ref.el @@ -1,6 +1,6 @@ ;;; ob-ref.el --- org-babel functions for referencing external data -;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Authors: Eric Schulte ;; Dan Davison @@ -53,6 +53,8 @@ (eval-when-compile (require 'cl)) +(declare-function org-end-of-meta-data "org" (&optional full)) +(declare-function org-find-property "org" (property &optional value)) (declare-function org-remove-if-not "org" (predicate seq)) (declare-function org-at-table-p "org" (&optional table-type)) (declare-function org-count "org" (CL-ITEM CL-SEQ)) @@ -63,6 +65,8 @@ (declare-function org-show-context "org" (&optional key)) (declare-function org-pop-to-buffer-same-window "org-compat" (&optional buffer-or-name norecord label)) +(declare-function org-babel-lob-execute "ob-lob" (info)) +(declare-function org-babel-lob-get-info "ob-lob" nil) (defvar org-babel-ref-split-regexp "[ \f\t\n\r\v]*\\(.+?\\)[ \f\t\n\r\v]*=[ \f\t\n\r\v]*\\(.+\\)[ \f\t\n\r\v]*") @@ -96,119 +100,125 @@ the variable." out)))))) (defun org-babel-ref-goto-headline-id (id) - (goto-char (point-min)) - (let ((rx (regexp-quote id))) - (or (re-search-forward - (concat "^[ \t]*:CUSTOM_ID:[ \t]+" rx "[ \t]*$") nil t) - (let* ((file (org-id-find-id-file id)) - (m (when file (org-id-find-id-in-file id file 'marker)))) - (when (and file m) - (message "file:%S" file) - (org-pop-to-buffer-same-window (marker-buffer m)) - (goto-char m) - (move-marker m nil) - (org-show-context) - t))))) + (or (let ((h (org-find-property "CUSTOM_ID" id))) + (when h (goto-char h))) + (let* ((file (org-id-find-id-file id)) + (m (when file (org-id-find-id-in-file id file 'marker)))) + (when (and file m) + (message "file:%S" file) + (org-pop-to-buffer-same-window (marker-buffer m)) + (goto-char m) + (move-marker m nil) + (org-show-context) + t)))) (defun org-babel-ref-headline-body () (save-restriction (org-narrow-to-subtree) (buffer-substring (save-excursion (goto-char (point-min)) - (forward-line 1) - (when (looking-at "[ \t]*:PROPERTIES:") - (re-search-forward ":END:" nil) - (forward-char)) + (org-end-of-meta-data) (point)) (point-max)))) +(defvar org-babel-lob-one-liner-regexp) (defvar org-babel-library-of-babel) (defun org-babel-ref-resolve (ref) "Resolve the reference REF and return its value." (save-window-excursion - (save-excursion - (let ((case-fold-search t) - type args new-refere new-header-args new-referent result - lob-info split-file split-ref index index-row index-col id) - ;; if ref is indexed grab the indices -- beware nested indices - (when (and (string-match "\\[\\([^\\[]+\\)\\]$" ref) - (let ((str (substring ref 0 (match-beginning 0)))) - (= (org-count ?( str) (org-count ?) str)))) - (setq index (match-string 1 ref)) - (setq ref (substring ref 0 (match-beginning 0)))) - ;; assign any arguments to pass to source block - (when (string-match - "^\\(.+?\\)\\(\\[\\(.*\\)\\]\\|\\(\\)\\)\(\\(.*\\)\)$" ref) - (setq new-refere (match-string 1 ref)) - (setq new-header-args (match-string 3 ref)) - (setq new-referent (match-string 5 ref)) - (when (> (length new-refere) 0) - (when (> (length new-referent) 0) - (setq args (mapcar (lambda (ref) (cons :var ref)) - (org-babel-ref-split-args new-referent)))) - (when (> (length new-header-args) 0) - (setq args (append (org-babel-parse-header-arguments - new-header-args) args))) - (setq ref new-refere))) - (when (string-match "^\\(.+\\):\\(.+\\)$" ref) - (setq split-file (match-string 1 ref)) - (setq split-ref (match-string 2 ref)) - (find-file split-file) (setq ref split-ref)) - (save-restriction - (widen) - (goto-char (point-min)) - (if (let ((src-rx (org-babel-named-src-block-regexp-for-name ref)) - (res-rx (org-babel-named-data-regexp-for-name ref))) - ;; goto ref in the current buffer - (or - ;; check for code blocks - (re-search-forward src-rx nil t) - ;; check for named data - (re-search-forward res-rx nil t) - ;; check for local or global headlines by id - (setq id (org-babel-ref-goto-headline-id ref)) - ;; check the Library of Babel - (setq lob-info (cdr (assoc (intern ref) - org-babel-library-of-babel))))) - (unless (or lob-info id) (goto-char (match-beginning 0))) - ;; ;; TODO: allow searching for names in other buffers - ;; (setq id-loc (org-id-find ref 'marker) - ;; buffer (marker-buffer id-loc) - ;; loc (marker-position id-loc)) - ;; (move-marker id-loc nil) - (error "Reference '%s' not found in this buffer" ref)) - (cond - (lob-info (setq type 'lob)) - (id (setq type 'id)) - ((and (looking-at org-babel-src-name-regexp) - (save-excursion - (forward-line 1) - (or (looking-at org-babel-src-block-regexp) - (looking-at org-babel-multi-line-header-regexp)))) - (setq type 'source-block)) - (t (while (not (setq type (org-babel-ref-at-ref-p))) - (forward-line 1) - (beginning-of-line) - (if (or (= (point) (point-min)) (= (point) (point-max))) - (error "Reference not found"))))) - (let ((params (append args '((:results . "silent"))))) - (setq result - (case type - (results-line (org-babel-read-result)) - (table (org-babel-read-table)) - (list (org-babel-read-list)) - (file (org-babel-read-link)) - (source-block (org-babel-execute-src-block - nil nil (if org-babel-update-intermediate - nil params))) - (lob (org-babel-execute-src-block - nil lob-info params)) - (id (org-babel-ref-headline-body))))) - (if (symbolp result) - (format "%S" result) - (if (and index (listp result)) - (org-babel-ref-index-list index result) - result))))))) + (with-current-buffer (or org-babel-exp-reference-buffer (current-buffer)) + (save-excursion + (let ((case-fold-search t) + type args new-refere new-header-args new-referent result + lob-info split-file split-ref index index-row index-col id) + ;; if ref is indexed grab the indices -- beware nested indices + (when (and (string-match "\\[\\([^\\[]+\\)\\]$" ref) + (let ((str (substring ref 0 (match-beginning 0)))) + (= (org-count ?( str) (org-count ?) str)))) + (setq index (match-string 1 ref)) + (setq ref (substring ref 0 (match-beginning 0)))) + ;; assign any arguments to pass to source block + (when (string-match + "^\\(.+?\\)\\(\\[\\(.*\\)\\]\\|\\(\\)\\)\(\\(.*\\)\)$" ref) + (setq new-refere (match-string 1 ref)) + (setq new-header-args (match-string 3 ref)) + (setq new-referent (match-string 5 ref)) + (when (> (length new-refere) 0) + (when (> (length new-referent) 0) + (setq args (mapcar (lambda (ref) (cons :var ref)) + (org-babel-ref-split-args new-referent)))) + (when (> (length new-header-args) 0) + (setq args (append (org-babel-parse-header-arguments + new-header-args) args))) + (setq ref new-refere))) + (when (string-match "^\\(.+\\):\\(.+\\)$" ref) + (setq split-file (match-string 1 ref)) + (setq split-ref (match-string 2 ref)) + (find-file split-file) (setq ref split-ref)) + (save-restriction + (widen) + (goto-char (point-min)) + (if (let ((src-rx (org-babel-named-src-block-regexp-for-name ref)) + (res-rx (org-babel-named-data-regexp-for-name ref))) + ;; goto ref in the current buffer + (or + ;; check for code blocks + (re-search-forward src-rx nil t) + ;; check for named data + (re-search-forward res-rx nil t) + ;; check for local or global headlines by id + (setq id (org-babel-ref-goto-headline-id ref)) + ;; check the Library of Babel + (setq lob-info (cdr (assoc (intern ref) + org-babel-library-of-babel))))) + (unless (or lob-info id) (goto-char (match-beginning 0))) + ;; ;; TODO: allow searching for names in other buffers + ;; (setq id-loc (org-id-find ref 'marker) + ;; buffer (marker-buffer id-loc) + ;; loc (marker-position id-loc)) + ;; (move-marker id-loc nil) + (error "Reference '%s' not found in this buffer" ref)) + (cond + (lob-info (setq type 'lob)) + (id (setq type 'id)) + ((and (looking-at org-babel-src-name-regexp) + (save-excursion + (forward-line 1) + (or (looking-at org-babel-src-block-regexp) + (looking-at org-babel-multi-line-header-regexp)))) + (setq type 'source-block)) + ((and (looking-at org-babel-src-name-regexp) + (save-excursion + (forward-line 1) + (looking-at org-babel-lob-one-liner-regexp))) + (setq type 'call-line)) + (t (while (not (setq type (org-babel-ref-at-ref-p))) + (forward-line 1) + (beginning-of-line) + (if (or (= (point) (point-min)) (= (point) (point-max))) + (error "Reference not found"))))) + (let ((params (append args '((:results . "silent"))))) + (setq result + (case type + (results-line (org-babel-read-result)) + (table (org-babel-read-table)) + (list (org-babel-read-list)) + (file (org-babel-read-link)) + (source-block (org-babel-execute-src-block + nil nil (if org-babel-update-intermediate + nil params))) + (call-line (save-excursion + (forward-line 1) + (org-babel-lob-execute + (org-babel-lob-get-info)))) + (lob (org-babel-execute-src-block + nil lob-info params)) + (id (org-babel-ref-headline-body))))) + (if (symbolp result) + (format "%S" result) + (if (and index (listp result)) + (org-babel-ref-index-list index result) + result)))))))) (defun org-babel-ref-index-list (index lis) "Return the subset of LIS indexed by INDEX. diff --git a/lisp/ob-ruby.el b/lisp/ob-ruby.el index 5b31247..2134fad 100644 --- a/lisp/ob-ruby.el +++ b/lisp/ob-ruby.el @@ -58,7 +58,7 @@ :type 'string) (defcustom org-babel-ruby-nil-to 'hline - "Replace 'nil' in ruby tables with this before returning." + "Replace nil in ruby tables with this before returning." :group 'org-babel :version "24.4" :package-version '(Org . "8.0") @@ -209,21 +209,32 @@ return the value of the last statement in BODY, as elisp." ;; comint session evaluation (case result-type (output - (mapconcat - #'identity - (butlast - (split-string - (mapconcat - #'org-babel-trim - (butlast - (org-babel-comint-with-output - (buffer org-babel-ruby-eoe-indicator t body) - (mapc - (lambda (line) - (insert (org-babel-chomp line)) (comint-send-input nil t)) - (list body org-babel-ruby-eoe-indicator)) - (comint-send-input nil t)) 2) - "\n") "[\r\n]")) "\n")) + (let ((eoe-string (format "puts \"%s\"" org-babel-ruby-eoe-indicator))) + ;; Force the session to be ready before the actual session + ;; code is run. There is some problem in comint that will + ;; sometimes show the prompt after the the input has already + ;; been inserted and that throws off the extraction of the + ;; result for Babel. + (org-babel-comint-with-output + (buffer org-babel-ruby-eoe-indicator t eoe-string) + (insert eoe-string) (comint-send-input nil t)) + ;; Now we can start the evaluation. + (mapconcat + #'identity + (butlast + (split-string + (mapconcat + #'org-babel-trim + (org-babel-comint-with-output + (buffer org-babel-ruby-eoe-indicator t body) + (mapc + (lambda (line) + (insert (org-babel-chomp line)) (comint-send-input nil t)) + (list "conf.echo=false;_org_prompt_mode=conf.prompt_mode;conf.prompt_mode=:NULL" + body + "conf.prompt_mode=_org_prompt_mode;conf.echo=true" + eoe-string))) + "\n") "[\r\n]") 4) "\n"))) (value (let* ((tmp-file (org-babel-temp-file "ruby-")) (ppp (or (member "code" result-params) diff --git a/lisp/ob-scala.el b/lisp/ob-scala.el index 0584342..838bc8f 100644 --- a/lisp/ob-scala.el +++ b/lisp/ob-scala.el @@ -60,14 +60,6 @@ called by `org-babel-execute-src-block'" (org-babel-pick-name (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) - -(defun org-babel-scala-table-or-string (results) - "Convert RESULTS into an appropriate elisp value. -If RESULTS look like a table, then convert them into an -Emacs-lisp table, otherwise return the results as a string." - (org-babel-script-escape results)) - - (defvar org-babel-scala-wrapper-method "var str_result :String = null; @@ -104,7 +96,7 @@ in BODY as elisp." (concat org-babel-scala-command " " src-file) ""))) (org-babel-result-cond result-params raw - (org-babel-scala-table-or-string raw))))))) + (org-babel-script-escape raw))))))) (defun org-babel-prep-session:scala (session params) diff --git a/lisp/ob-scheme.el b/lisp/ob-scheme.el index b7117e9..2095534 100644 --- a/lisp/ob-scheme.el +++ b/lisp/ob-scheme.el @@ -118,6 +118,22 @@ org-babel-scheme-execute-with-geiser will use a temporary session." (name)))) result)) +(defmacro org-babel-scheme-capture-current-message (&rest body) + "Capture current message in both interactive and noninteractive mode" + `(if noninteractive + (let ((original-message (symbol-function 'message)) + (current-message nil)) + (unwind-protect + (progn + (defun message (&rest args) + (setq current-message (apply original-message args))) + ,@body + current-message) + (fset 'message original-message))) + (progn + ,@body + (current-message)))) + (defun org-babel-scheme-execute-with-geiser (code output impl repl) "Execute code in specified REPL. If the REPL doesn't exist, create it using the given scheme implementation. @@ -142,10 +158,11 @@ is true; otherwise returns the last value." (current-buffer))))) (setq geiser-repl--repl repl-buffer) (setq geiser-impl--implementation nil) - (geiser-eval-region (point-min) (point-max)) + (setq result (org-babel-scheme-capture-current-message + (geiser-eval-region (point-min) (point-max)))) (setq result - (if (equal (substring (current-message) 0 3) "=> ") - (replace-regexp-in-string "^=> " "" (current-message)) + (if (and (stringp result) (equal (substring result 0 3) "=> ")) + (replace-regexp-in-string "^=> " "" result) "\"An error occurred.\"")) (when (not repl) (save-current-buffer (set-buffer repl-buffer) diff --git a/lisp/ob-sed.el b/lisp/ob-sed.el new file mode 100644 index 0000000..9e3db37 --- /dev/null +++ b/lisp/ob-sed.el @@ -0,0 +1,107 @@ +;;; ob-sed.el --- org-babel functions for sed scripts + +;; Copyright (C) 2015 Free Software Foundation + +;; Author: Bjarte Johansen +;; Keywords: literate programming, reproducible research +;; Version: 0.1.0 + +;; This file is part of GNU Emacs. + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Provides a way to evaluate sed scripts in Org mode. + +;;; Usage: + +;; Add to your Emacs config: + +;; (org-babel-do-load-languages +;; 'org-babel-load-languages +;; '((sed . t))) + +;; In addition to the normal header arguments, ob-sed also provides +;; :cmd-line and :in-file. :cmd-line allows one to pass other flags to +;; the sed command like the "--in-place" flag which makes sed edit the +;; file pass to it instead of outputting to standard out or to a +;; different file. :in-file is a header arguments that allows one to +;; tell Org Babel which file the sed script to act on. + +;;; Code: +(require 'ob) + +(defvar org-babel-sed-command "sed" + "Name of the sed executable command.") + +(defvar org-babel-tangle-lang-exts) +(add-to-list 'org-babel-tangle-lang-exts '("sed" . "sed")) + +(defconst org-babel-header-args:sed + '((:cmd-line . :any) + (:in-file . :any)) + "Sed specific header arguments.") + +(defvar org-babel-default-header-args:sed '() + "Default arguments for evaluating a sed source block.") + +(defun org-babel-execute:sed (body params) + "Execute a block of sed code with Org Babel. +BODY is the source inside a sed source block and PARAMS is an +association list over the source block configurations. This +function is called by `org-babel-execute-src-block'." + (message "executing sed source code block") + (let* ((result-params (cdr (assq :result-params params))) + (cmd-line (cdr (assq :cmd-line params))) + (in-file (cdr (assq :in-file params))) + (code-file (let ((file (org-babel-temp-file "sed-"))) + (with-temp-file file + (insert body)) file)) + (stdin (let ((stdin (cdr (assq :stdin params)))) + (when stdin + (let ((tmp (org-babel-temp-file "sed-stdin-")) + (res (org-babel-ref-resolve stdin))) + (with-temp-file tmp + (insert res)) + tmp)))) + (cmd (mapconcat #'identity + (remq nil + (list org-babel-sed-command + (format "--file=\"%s\"" code-file) + cmd-line + in-file)) + " "))) + (org-babel-reassemble-table + (let ((results + (cond + (stdin (with-temp-buffer + (call-process-shell-command cmd stdin (current-buffer)) + (buffer-string))) + (t (org-babel-eval cmd ""))))) + (when results + (org-babel-result-cond result-params + results + (let ((tmp (org-babel-temp-file "sed-results-"))) + (with-temp-file tmp (insert results)) + (org-babel-import-elisp-from-file tmp))))) + (org-babel-pick-name + (cdr (assq :colname-names params)) (cdr (assq :colnames params))) + (org-babel-pick-name + (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))) + +(provide 'ob-sed) +;;; ob-sed.el ends here diff --git a/lisp/ob-sh.el b/lisp/ob-shell.el index 856c7a0..3ee2f4d 100644 --- a/lisp/ob-sh.el +++ b/lisp/ob-shell.el @@ -1,4 +1,4 @@ -;;; ob-sh.el --- org-babel functions for shell evaluation +;;; ob-shell.el --- org-babel functions for shell evaluation ;; Copyright (C) 2009-2014 Free Software Foundation, Inc. @@ -36,19 +36,25 @@ (declare-function org-babel-comint-with-output "ob-comint" (meta &rest body)) (declare-function orgtbl-to-generic "org-table" (table params)) -(defvar org-babel-default-header-args:sh '()) +(defvar org-babel-default-header-args:shell '()) -(defvar org-babel-sh-command "sh" - "Command used to invoke a shell. -This will be passed to `shell-command-on-region'") - -(defcustom org-babel-sh-var-quote-fmt - "$(cat <<'BABEL_TABLE'\n%s\nBABEL_TABLE\n)" - "Format string used to escape variables when passed to shell scripts." +(defcustom org-babel-shell-names + '("sh" "bash" "csh" "ash" "dash" "ksh" "mksh" "posh") + "List of names of shell supported by babel shell code blocks." :group 'org-babel - :type 'string) + :type 'string + :initialize + (lambda (symbol value) + (set-default symbol (second value)) + (mapc + (lambda (name) + (eval `(defun ,(intern (concat "org-babel-execute:" name)) (body params) + ,(format "Execute a block of %s commands with Babel." name) + (let ((shell-file-name ,name)) + (org-babel-execute:shell body params))))) + (second value)))) -(defun org-babel-execute:sh (body params) +(defun org-babel-execute:shell (body params) "Execute a block of Shell commands with Babel. This function is called by `org-babel-execute-src-block'." (let* ((session (org-babel-sh-initiate-session @@ -56,68 +62,108 @@ This function is called by `org-babel-execute-src-block'." (stdin (let ((stdin (cdr (assoc :stdin params)))) (when stdin (org-babel-sh-var-to-string (org-babel-ref-resolve stdin))))) + (cmdline (cdr (assoc :cmdline params))) (full-body (org-babel-expand-body:generic - body params (org-babel-variable-assignments:sh params)))) + body params (org-babel-variable-assignments:shell params)))) (org-babel-reassemble-table - (org-babel-sh-evaluate session full-body params stdin) + (org-babel-sh-evaluate session full-body params stdin cmdline) (org-babel-pick-name (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) (org-babel-pick-name (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) -(defun org-babel-prep-session:sh (session params) +(defun org-babel-prep-session:shell (session params) "Prepare SESSION according to the header arguments specified in PARAMS." (let* ((session (org-babel-sh-initiate-session session)) - (var-lines (org-babel-variable-assignments:sh params))) + (var-lines (org-babel-variable-assignments:shell params))) (org-babel-comint-in-buffer session (mapc (lambda (var) (insert var) (comint-send-input nil t) (org-babel-comint-wait-for-output session)) var-lines)) session)) -(defun org-babel-load-session:sh (session body params) +(defun org-babel-load-session:shell (session body params) "Load BODY into SESSION." (save-window-excursion - (let ((buffer (org-babel-prep-session:sh session params))) + (let ((buffer (org-babel-prep-session:shell session params))) (with-current-buffer buffer (goto-char (process-mark (get-buffer-process (current-buffer)))) (insert (org-babel-chomp body))) buffer))) ;; helper functions +(defun org-babel-variable-assignments:sh-generic + (varname values &optional sep hline) + "Returns a list of statements declaring the values as a generic variable." + (format "%s=%s" varname (org-babel-sh-var-to-sh values sep hline))) + +(defun org-babel-variable-assignments:bash_array + (varname values &optional sep hline) + "Returns a list of statements declaring the values as a bash array." + (format "unset %s\ndeclare -a %s=( %s )" + varname varname + (mapconcat + (lambda (value) (org-babel-sh-var-to-sh value sep hline)) + values + " "))) + +(defun org-babel-variable-assignments:bash_assoc + (varname values &optional sep hline) + "Returns a list of statements declaring the values as bash associative array." + (format "unset %s\ndeclare -A %s\n%s" + varname varname + (mapconcat + (lambda (items) + (format "%s[%s]=%s" + varname + (org-babel-sh-var-to-sh (car items) sep hline) + (org-babel-sh-var-to-sh (cdr items) sep hline))) + values + "\n"))) -(defun org-babel-variable-assignments:sh (params) +(defun org-babel-variable-assignments:bash (varname values &optional sep hline) + "Represents the parameters as useful Bash shell variables." + (if (listp values) + (if (and (listp (car values)) (= 1 (length (car values)))) + (org-babel-variable-assignments:bash_array varname values sep hline) + (org-babel-variable-assignments:bash_assoc varname values sep hline)) + (org-babel-variable-assignments:sh-generic varname values sep hline))) + +(defun org-babel-variable-assignments:shell (params) "Return list of shell statements assigning the block's variables." - (let ((sep (cdr (assoc :separator params)))) + (let ((sep (cdr (assoc :separator params))) + (hline (when (string= "yes" (cdr (assoc :hlines params))) + (or (cdr (assoc :hline-string params)) + "hline")))) (mapcar (lambda (pair) - (format "%s=%s" - (car pair) - (org-babel-sh-var-to-sh (cdr pair) sep))) + (if (string-match "bash$" shell-file-name) + (org-babel-variable-assignments:bash + (car pair) (cdr pair) sep hline) + (org-babel-variable-assignments:sh-generic + (car pair) (cdr pair) sep hline))) (mapcar #'cdr (org-babel-get-header params :var))))) -(defun org-babel-sh-var-to-sh (var &optional sep) +(defun org-babel-sh-var-to-sh (var &optional sep hline) "Convert an elisp value to a shell variable. Convert an elisp var into a string of shell commands specifying a var of the same value." - (format org-babel-sh-var-quote-fmt (org-babel-sh-var-to-string var sep))) + (concat "'" (replace-regexp-in-string + "'" "'\"'\"'" + (org-babel-sh-var-to-string var sep hline)) + "'")) -(defun org-babel-sh-var-to-string (var &optional sep) +(defun org-babel-sh-var-to-string (var &optional sep hline) "Convert an elisp value to a string." (let ((echo-var (lambda (v) (if (stringp v) v (format "%S" v))))) (cond ((and (listp var) (or (listp (car var)) (equal (car var) 'hline))) - (orgtbl-to-generic var (list :sep (or sep "\t") :fmt echo-var))) + (orgtbl-to-generic var (list :sep (or sep "\t") :fmt echo-var + :hline hline))) ((listp var) (mapconcat echo-var var "\n")) (t (funcall echo-var var))))) -(defun org-babel-sh-table-or-results (results) - "Convert RESULTS to an appropriate elisp value. -If the results look like a table, then convert them into an -Emacs-lisp table, otherwise return the results as a string." - (org-babel-script-escape results)) - (defun org-babel-sh-initiate-session (&optional session params) "Initiate a session named SESSION according to PARAMS." (when (and session (not (string= session "none"))) @@ -136,14 +182,14 @@ Emacs-lisp table, otherwise return the results as a string." (defvar org-babel-sh-eoe-output "org_babel_sh_eoe" "String to indicate that evaluation has completed.") -(defun org-babel-sh-evaluate (session body &optional params stdin) +(defun org-babel-sh-evaluate (session body &optional params stdin cmdline) "Pass BODY to the Shell process in BUFFER. If RESULT-TYPE equals 'output then return a list of the outputs of the statements in BODY, if RESULT-TYPE equals 'value then return the value of the last statement in BODY." (let ((results (cond - (stdin ; external shell script w/STDIN + ((or stdin cmdline) ; external shell script w/STDIN (let ((script-file (org-babel-temp-file "sh-script-")) (stdin-file (org-babel-temp-file "sh-stdin-")) (shebang (cdr (assoc :shebang params))) @@ -153,14 +199,14 @@ return the value of the last statement in BODY." (when padline (insert "\n")) (insert body)) (set-file-modes script-file #o755) - (with-temp-file stdin-file (insert stdin)) + (with-temp-file stdin-file (insert (or stdin ""))) (with-temp-buffer (call-process-shell-command - (if shebang - script-file - (format "%s %s" org-babel-sh-command script-file)) + (concat (if shebang script-file + (format "%s %s" shell-file-name script-file)) + (and cmdline (concat " " cmdline))) stdin-file - (current-buffer)) + (current-buffer)) (buffer-string)))) (session ; session evaluation (mapconcat @@ -196,7 +242,7 @@ return the value of the last statement in BODY." (insert body)) (set-file-modes script-file #o755) (org-babel-eval script-file "")) - (org-babel-eval org-babel-sh-command (org-babel-trim body))))))) + (org-babel-eval shell-file-name (org-babel-trim body))))))) (when results (let ((result-params (cdr (assoc :result-params params)))) (org-babel-result-cond result-params @@ -211,8 +257,8 @@ return the value of the last statement in BODY." (setq string (substring string (match-end 0)))) string) -(provide 'ob-sh) +(provide 'ob-shell) -;;; ob-sh.el ends here +;;; ob-shell.el ends here diff --git a/lisp/ob-sql.el b/lisp/ob-sql.el index 08d4419..c29b175 100644 --- a/lisp/ob-sql.el +++ b/lisp/ob-sql.el @@ -36,6 +36,7 @@ ;; - engine ;; - cmdline ;; - dbhost +;; - dbport ;; - dbuser ;; - dbpassword ;; - database @@ -68,6 +69,7 @@ '((engine . :any) (out-file . :any) (dbhost . :any) + (dbport . :any) (dbuser . :any) (dbpassword . :any) (database . :any)) @@ -78,21 +80,32 @@ (org-babel-sql-expand-vars body (mapcar #'cdr (org-babel-get-header params :var)))) -(defun dbstring-mysql (host user password database) +(defun org-babel-sql-dbstring-mysql (host port user password database) "Make MySQL cmd line args for database connection. Pass nil to omit that arg." (combine-and-quote-strings - (remq nil + (delq nil (list (when host (concat "-h" host)) + (when port (format "-P%d" port)) (when user (concat "-u" user)) (when password (concat "-p" password)) (when database (concat "-D" database)))))) +(defun org-babel-sql-dbstring-postgresql (host user database) + "Make PostgreSQL command line args for database connection. +Pass nil to omit that arg." + (combine-and-quote-strings + (delq nil + (list (when host (concat "-h" host)) + (when user (concat "-U" user)) + (when database (concat "-d" database)))))) + (defun org-babel-execute:sql (body params) "Execute a block of Sql code with Babel. This function is called by `org-babel-execute-src-block'." (let* ((result-params (cdr (assoc :result-params params))) (cmdline (cdr (assoc :cmdline params))) (dbhost (cdr (assoc :dbhost params))) + (dbport (cdr (assq :dbport params))) (dbuser (cdr (assoc :dbuser params))) (dbpassword (cdr (assoc :dbpassword params))) (database (cdr (assoc :database params))) @@ -117,13 +130,16 @@ This function is called by `org-babel-execute-src-block'." (org-babel-process-file-name in-file) (org-babel-process-file-name out-file))) ('mysql (format "mysql %s %s %s < %s > %s" - (dbstring-mysql dbhost dbuser dbpassword database) + (org-babel-sql-dbstring-mysql + dbhost dbport dbuser dbpassword database) (if colnames-p "" "-N") (or cmdline "") (org-babel-process-file-name in-file) (org-babel-process-file-name out-file))) ('postgresql (format - "psql -A -P footer=off -F \"\t\" -f %s -o %s %s" + "psql --set=\"ON_ERROR_STOP=1\" %s -A -P footer=off -F \"\t\" %s -f %s -o %s %s" + (if colnames-p "" "-t") + (org-babel-sql-dbstring-postgresql dbhost dbuser database) (org-babel-process-file-name in-file) (org-babel-process-file-name out-file) (or cmdline ""))) diff --git a/lisp/ob-table.el b/lisp/ob-table.el index 831e352..b2a8da6 100644 --- a/lisp/ob-table.el +++ b/lisp/ob-table.el @@ -47,7 +47,10 @@ ;; | 7 | | ;; | 8 | | ;; | 9 | | -;; #+TBLFM: $2='(org-sbe 'fibbd (n $1)) +;; #+TBLFM: $2='(org-sbe "fibbd" (n $1)) + +;; NOTE: The quotation marks around the function name, 'fibbd' here, +;; are optional. ;;; Code: (require 'ob-core) @@ -62,23 +65,30 @@ character and replace it with ellipses." (defmacro org-sbe (source-block &rest variables) "Return the results of calling SOURCE-BLOCK with VARIABLES. -Each element of VARIABLES should be a two -element list, whose first element is the name of the variable and -second element is a string of its value. The following call to -`org-sbe' would be equivalent to the following source code block. - (org-sbe 'source-block (n $2) (m 3)) +Each element of VARIABLES should be a list of two elements: the +first element is the name of the variable and second element is a +string of its value. + +So this `org-sbe' construct + + (org-sbe \"source-block\" (n $2) (m 3)) + +is the equivalent of the following source code block: + + #+begin_src emacs-lisp :var results=source-block(n=val_at_col_2, m=3) :results silent + results + #+end_src -#+begin_src emacs-lisp :var results=source-block(n=val_at_col_2, m=3) :results silent -results -#+end_src +NOTE: The quotation marks around the function name, +'source-block', are optional. -NOTE: by default string variable names are interpreted as +NOTE: By default, string variable names are interpreted as references to source-code blocks, to force interpretation of a cell's value as a string, prefix the identifier a \"$\" (e.g., \"$$2\" instead of \"$2\" or \"$@2$2\" instead of \"@2$2\"). -NOTE: it is also possible to pass header arguments to the code +NOTE: It is also possible to pass header arguments to the code block. In this case a table cell should hold the string value of the header argument which can then be passed before all variables as shown in the example below. diff --git a/lisp/ob-tangle.el b/lisp/ob-tangle.el index 3a43b42..385d8e2 100644 --- a/lisp/ob-tangle.el +++ b/lisp/ob-tangle.el @@ -27,21 +27,24 @@ ;;; Code: (require 'org-src) -(eval-when-compile - (require 'cl)) +(declare-function make-directory "files" (dir &optional parents)) +(declare-function org-babel-update-block-body "org" (new-body)) +(declare-function org-back-to-heading "org" (invisible-ok)) +(declare-function org-before-first-heading-p "org" ()) (declare-function org-edit-special "org" (&optional arg)) +(declare-function org-fill-template "org" (template alist)) +(declare-function org-heading-components "org" ()) +(declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) (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)) +(declare-function org-store-link "org" (arg)) +(declare-function org-up-heading-safe "org" ()) +(declare-function outline-previous-heading "outline" ()) (defcustom org-babel-tangle-lang-exts - '(("emacs-lisp" . "el")) + '(("emacs-lisp" . "el") + ("elisp" . "el")) "Alist mapping languages to their file extensions. The key is the language name, the value is the string that should be inserted as the extension commonly used to identify files @@ -54,6 +57,11 @@ then the name of the language is used." (string "Language name") (string "File Extension")))) +(defcustom org-babel-tangle-use-relative-file-links t + "Use relative path names in links from tangled source back the Org-mode file." + :group 'org-babel-tangle + :type 'boolean) + (defcustom org-babel-post-tangle-hook nil "Hook run in code files tangled by `org-babel-tangle'." :group 'org-babel @@ -81,6 +89,11 @@ information into the output using `org-fill-template'. %link --------- Org-mode style link to the code block %source-name -- name of the code block +Upon insertion the formatted comment will be commented out, and +followed by a newline. To inhibit this post-insertion processing +set the `org-babel-tangle-uncomment-comments' variable to a +non-nil value. + Whether or not comments are inserted during tangling is controlled by the :comments header argument." :group 'org-babel @@ -96,17 +109,30 @@ information into the output using `org-fill-template'. %link --------- Org-mode style link to the code block %source-name -- name of the code block +Upon insertion the formatted comment will be commented out, and +followed by a newline. To inhibit this post-insertion processing +set the `org-babel-tangle-uncomment-comments' variable to a +non-nil value. + Whether or not comments are inserted during tangling is controlled by the :comments header argument." :group 'org-babel :version "24.1" :type 'string) -(defcustom org-babel-process-comment-text #'org-babel-trim +(defcustom org-babel-tangle-uncomment-comments nil + "Inhibits automatic commenting and addition of trailing newline +of tangle comments. Use `org-babel-tangle-comment-format-beg' +and `org-babel-tangle-comment-format-end' to customize the format +of tangled comments." + :group 'org-babel + :type 'boolean) + +(defcustom org-babel-process-comment-text #'org-remove-indentation "Function called to process raw Org-mode text collected to be inserted as comments in tangled source-code files. The function should take a single string argument and return a string -result. The default value is `org-babel-trim'." +result. The default value is `org-remove-indentation'." :group 'org-babel :version "24.1" :type 'function) @@ -176,12 +202,12 @@ used to limit the exported source code blocks by language." (run-hooks 'org-babel-pre-tangle-hook) ;; Possibly Restrict the buffer to the current code block (save-restriction - (when (equal arg '(4)) - (let ((head (org-babel-where-is-src-block-head))) + (save-excursion + (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 (if target-file @@ -246,6 +272,10 @@ used to limit the exported source code blocks by language." (if (file-exists-p file-name) (insert-file-contents file-name)) (goto-char (point-max)) + ;; Handle :padlines unless first line in file + (unless (or (string= "no" (cdr (assoc :padline (nth 4 spec)))) + (= (point) (point-min))) + (insert "\n")) (insert content) (write-region nil nil file-name)))) ;; if files contain she-bangs, then make the executable @@ -304,13 +334,23 @@ 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)) - (file (nth 1 spec)) - (link (nth 2 spec)) + (file (if org-babel-tangle-use-relative-file-links + (file-relative-name (nth 1 spec)) + (nth 1 spec))) + (link (let ((link (nth 2 spec))) + (if org-babel-tangle-use-relative-file-links + (when (string-match "^\\(file:\\|docview:\\)\\(.*\\)" link) + (let* ((type (match-string 1 link)) + (path (match-string 2 link)) + (origpath path) + (case-fold-search nil)) + (setq path (file-relative-name path)) + (concat type path))) + link))) (source-name (nth 3 spec)) (body (nth 5 spec)) (comment (nth 6 spec)) (comments (cdr (assoc :comments (nth 4 spec)))) - (padline (not (string= "no" (cdr (assoc :padline (nth 4 spec)))))) (link-p (or (string= comments "both") (string= comments "link") (string= comments "yes") (string= comments "noweb"))) (link-data (mapcar (lambda (el) @@ -321,15 +361,20 @@ that the appropriate major-mode is set. SPEC has the form: (insert-comment (lambda (text) (when (and comments (not (string= comments "no")) (> (length text) 0)) - (when padline (insert "\n")) - (comment-region (point) (progn (insert text) (point))) - (end-of-line nil) (insert "\n"))))) + (if org-babel-tangle-uncomment-comments + ;; just plain comments with no processing + (insert text) + ;; ensure comments are made to be + ;; comments, and add a trailing newline + (comment-region + (point) (progn (insert text) (point))) + (end-of-line nil) + (insert "\n")))))) (when comment (funcall insert-comment comment)) (when link-p (funcall insert-comment (org-fill-template org-babel-tangle-comment-format-beg link-data))) - (when padline (insert "\n")) (insert (format "%s\n" @@ -340,49 +385,36 @@ that the appropriate major-mode is set. SPEC has the form: insert-comment (org-fill-template org-babel-tangle-comment-format-end link-data))))) -(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. + "Collect source blocks in the current Org 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 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) + (let ((counter 0) last-heading-pos blocks) (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* ((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))) - ;; 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)) + (let ((current-heading-pos + (org-with-wide-buffer + (org-with-limited-levels (outline-previous-heading))))) + (cond ((eq last-heading-pos current-heading-pos) (incf counter)) + ((= counter 1)) + (t (setq counter 1)))) + (unless (org-in-commented-heading-p) + (let* ((info (org-babel-get-src-block-info 'light)) + (src-lang (nth 0 info)) + (src-tfile (cdr (assq :tangle (nth 2 info))))) + (unless (or (string= (cdr (assq :tangle (nth 2 info))) "no") + (and tangle-file (not (equal tangle-file src-tfile))) + (and language (not (string= language src-lang)))) + ;; Add the spec for this block to blocks under its + ;; language. + (let ((by-lang (assoc src-lang blocks)) + (block (org-babel-tangle-single-block counter))) + (if by-lang (setcdr by-lang (cons block (cdr by-lang))) + (push (cons src-lang (list block)) blocks))))))) + ;; Ensure blocks are in the correct order. + (mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) blocks))) (defun org-babel-tangle-single-block (block-counter &optional only-this-block) diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el index c11c1c8..c5cd21d 100644 --- a/lisp/org-agenda.el +++ b/lisp/org-agenda.el @@ -1,6 +1,6 @@ ;;; org-agenda.el --- Dynamic task and appointment lists for Org -;; Copyright (C) 2004-2014 Free Software Foundation, Inc. +;; Copyright (C) 2004-2015 Free Software Foundation, Inc. ;; Author: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: outlines, hypermedia, calendar, wp @@ -52,7 +52,7 @@ (declare-function diary-add-to-list "diary-lib" (date string specifier &optional marker globcolor literal)) -(declare-function calendar-absolute-from-iso "cal-iso" (date)) +(declare-function calendar-iso-to-absolute "cal-iso" (date)) (declare-function calendar-astro-date-string "cal-julian" (&optional date)) (declare-function calendar-bahai-date-string "cal-bahai" (&optional date)) (declare-function calendar-chinese-date-string "cal-china" (&optional date)) @@ -69,6 +69,7 @@ (declare-function calendar-persian-date-string "cal-persia" (&optional date)) (declare-function calendar-check-holidays "holidays" (date)) +(declare-function org-columns-remove-overlays "org-colview" ()) (declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction)) (declare-function org-columns-quit "org-colview" ()) @@ -360,6 +361,12 @@ the daily/weekly agenda, see `org-agenda-skip-function'.") (const :format "" quote) (repeat (string :tag "+tag or -tag")))) + (list :tag "Effort filter preset" + (const org-agenda-effort-filter-preset) + (list + (const :format "" quote) + (repeat + (string :tag "+=10 or -=10 or +<10 or ->10")))) (list :tag "Regexp filter preset" (const org-agenda-regexp-filter-preset) (list @@ -610,15 +617,6 @@ or `C-c a #' to produce the list." (repeat :tag "Projects are *not* stuck if they have an entry with TAG being any of" (string)) (regexp :tag "Projects are *not* stuck if this regexp matches inside the subtree"))) -(defcustom org-agenda-filter-effort-default-operator "<" - "The default operator for effort estimate filtering. -If you select an effort estimate limit without first pressing an operator, -this one will be used." - :group 'org-agenda-custom-commands - :type '(choice (const :tag "less or equal" "<") - (const :tag "greater or equal"">") - (const :tag "equal" "="))) - (defgroup org-agenda-skip nil "Options concerning skipping parts of agenda files." :tag "Org Agenda Skip" @@ -1097,6 +1095,7 @@ Possible values for this option are: current-window Show agenda in the current window, keeping all other windows. other-window Use `switch-to-buffer-other-window' to display agenda. +only-window Show agenda, deleting all other windows. reorganize-frame Show only two windows on the current frame, the current window and the agenda. other-frame Use `switch-to-buffer-other-frame' to display agenda. @@ -1107,6 +1106,7 @@ See also the variable `org-agenda-restore-windows-after-quit'." (const current-window) (const other-frame) (const other-window) + (const only-window) (const reorganize-frame))) (defcustom org-agenda-window-frame-fractions '(0.5 . 0.75) @@ -2070,7 +2070,7 @@ When nil, `q' will kill the single agenda buffer." (setq org-agenda-sticky new-value) (org-agenda-kill-all-agenda-buffers) (and (org-called-interactively-p 'interactive) - (message "Sticky agenda was %s" + (message "Sticky agenda %s" (if org-agenda-sticky "enabled" "disabled")))))) (defvar org-agenda-buffer nil @@ -2080,6 +2080,8 @@ When nil, `q' will kill the single agenda buffer." (defvar org-agenda-this-buffer-name nil) (defvar org-agenda-doing-sticky-redo nil) (defvar org-agenda-this-buffer-is-sticky nil) +(defvar org-agenda-last-indirect-buffer nil + "Last buffer loaded by `org-agenda-tree-to-indirect-buffer'.") (defconst org-agenda-local-vars '(org-agenda-this-buffer-name @@ -2101,8 +2103,10 @@ When nil, `q' will kill the single agenda buffer." org-agenda-category-filter org-agenda-top-headline-filter org-agenda-regexp-filter + org-agenda-effort-filter org-agenda-markers org-agenda-last-search-view-search-was-boolean + org-agenda-last-indirect-buffer org-agenda-filtered-by-category org-agenda-filter-form org-agenda-cycle-counter @@ -2309,6 +2313,7 @@ The following commands are available: (org-defkey org-agenda-mode-map "{" 'org-agenda-manipulate-query-add-re) (org-defkey org-agenda-mode-map "}" 'org-agenda-manipulate-query-subtract-re) (org-defkey org-agenda-mode-map "/" 'org-agenda-filter-by-tag) +(org-defkey org-agenda-mode-map "_" 'org-agenda-filter-by-effort) (org-defkey org-agenda-mode-map "=" 'org-agenda-filter-by-regexp) (org-defkey org-agenda-mode-map "|" 'org-agenda-filter-remove-all) (org-defkey org-agenda-mode-map "\\" 'org-agenda-filter-by-tag-refine) @@ -2322,6 +2327,10 @@ The following commands are available: (org-defkey org-agenda-mode-map [mouse-2] 'org-agenda-goto-mouse) (org-defkey org-agenda-mode-map [mouse-3] 'org-agenda-show-mouse) + +(define-key org-agenda-mode-map [remap forward-paragraph] 'org-agenda-forward-block) +(define-key org-agenda-mode-map [remap backward-paragraph] 'org-agenda-backward-block) + (when org-agenda-mouse-1-follows-link (org-defkey org-agenda-mode-map [follow-link] 'mouse-face)) (easy-menu-define org-agenda-menu org-agenda-mode-map "Agenda menu" @@ -2538,7 +2547,7 @@ For example, if you have a custom agenda command \"p\" and you want this command to be accessible only from plain text files, use this: - '((\"p\" ((in-file . \"\\.txt\")))) + '((\"p\" ((in-file . \"\\\\.txt\\\\'\")))) Here are the available contexts definitions: @@ -2556,7 +2565,7 @@ accessible if there is at least one valid check. You can also bind a key to another agenda custom command depending on contextual rules. - '((\"p\" \"q\" ((in-file . \"\\.txt\")))) + '((\"p\" \"q\" ((in-file . \"\\\\.txt\\\\'\")))) Here it means: in .txt files, use \"p\" as the key for the agenda command otherwise associated with \"q\". (The command @@ -3067,10 +3076,13 @@ L Timeline for current buffer # List stuck projects (!=configure) "Fit the window to the buffer size." (and (memq org-agenda-window-setup '(reorganize-frame)) (fboundp 'fit-window-to-buffer) - (org-fit-window-to-buffer - nil - (floor (* (frame-height) (cdr org-agenda-window-frame-fractions))) - (floor (* (frame-height) (car org-agenda-window-frame-fractions)))))) + (if (and (= (cdr org-agenda-window-frame-fractions) 1.0) + (= (car org-agenda-window-frame-fractions) 1.0)) + (delete-other-windows) + (org-fit-window-to-buffer + nil + (floor (* (frame-height) (cdr org-agenda-window-frame-fractions))) + (floor (* (frame-height) (car org-agenda-window-frame-fractions))))))) (defvar org-cmd nil) (defvar org-agenda-overriding-cmd nil) @@ -3306,19 +3318,20 @@ This ensures the export commands can easily use it." (defvar org-agenda-write-buffer-name "Agenda View") (defun org-agenda-write (file &optional open nosettings agenda-bufname) "Write the current buffer (an agenda view) as a file. + Depending on the extension of the file name, plain text (.txt), HTML (.html or .htm), PDF (.pdf) or Postscript (.ps) is produced. -If the extension is .ics, run icalendar export over all files used -to construct the agenda and limit the export to entries listed in the -agenda now. -If the extension is .org, collect all subtrees corresponding to the -agenda entries and add them in an .org file. -With prefix argument OPEN, open the new file immediately. -If NOSETTINGS is given, do not scope the settings of -`org-agenda-exporter-settings' into the export commands. This is used when -the settings have already been scoped and we do not wish to overrule other, -higher priority settings. -If AGENDA-BUFFER-NAME, use this as the buffer name for the agenda to write." +If the extension is .ics, translate visible agenda into iCalendar +format. If the extension is .org, collect all subtrees +corresponding to the agenda entries and add them in an .org file. + +With prefix argument OPEN, open the new file immediately. If +NOSETTINGS is given, do not scope the settings of +`org-agenda-exporter-settings' into the export commands. This is +used when the settings have already been scoped and we do not +wish to overrule other, higher priority settings. If +AGENDA-BUFFER-NAME is provided, use this as the buffer name for +the agenda to write." (interactive "FWrite agenda to file: \nP") (if (or (not (file-writable-p file)) (and (file-exists-p file) @@ -3531,6 +3544,7 @@ removed from the entry content. Currently only `planning' is allowed here." (defvar org-agenda-tag-filter nil) (defvar org-agenda-category-filter nil) (defvar org-agenda-regexp-filter nil) +(defvar org-agenda-effort-filter nil) (defvar org-agenda-top-headline-filter nil) (defvar org-agenda-tag-filter-preset nil "A preset of the tags filter used for secondary agenda filtering. @@ -3562,6 +3576,16 @@ the entire agenda view. In a block agenda, it will not work reliably to define a filter for one of the individual blocks. You need to set it in the global options and expect it to be applied to the entire view.") +(defvar org-agenda-effort-filter-preset nil + "A preset of the effort condition used for secondary agenda filtering. +This must be a list of strings, each string must be a single regexp +preceded by \"+\" or \"-\". +This variable should not be set directly, but agenda custom commands can +bind it in the options section. The preset filter is a global property of +the entire agenda view. In a block agenda, it will not work reliably to +define a filter for one of the individual blocks. You need to set it in +the global options and expect it to be applied to the entire view.") + (defun org-agenda-use-sticky-p () "Return non-nil if an agenda buffer named `org-agenda-buffer-name' exists and should be shown instead of @@ -3599,24 +3623,31 @@ FILTER-ALIST is an alist of filters we need to apply when (org-switch-to-buffer-other-window abuf)) ((equal org-agenda-window-setup 'other-frame) (switch-to-buffer-other-frame abuf)) + ((eq org-agenda-window-setup 'only-window) + (delete-other-windows) + (org-pop-to-buffer-same-window abuf)) ((equal org-agenda-window-setup 'reorganize-frame) (delete-other-windows) (org-switch-to-buffer-other-window abuf))) (setq org-agenda-tag-filter (cdr (assoc 'tag filter-alist))) (setq org-agenda-category-filter (cdr (assoc 'cat filter-alist))) + (setq org-agenda-effort-filter (cdr (assoc 'effort filter-alist))) (setq org-agenda-regexp-filter (cdr (assoc 're filter-alist))) ;; Additional test in case agenda is invoked from within agenda ;; buffer via elisp link. (unless (equal (current-buffer) abuf) (org-pop-to-buffer-same-window abuf)) (setq org-agenda-pre-window-conf - (or org-agenda-pre-window-conf wconf)))) + (or wconf org-agenda-pre-window-conf)))) (defun org-agenda-prepare (&optional name) (let ((filter-alist (if org-agenda-persistent-filter - (list `(tag . ,org-agenda-tag-filter) - `(re . ,org-agenda-regexp-filter) - `(car . ,org-agenda-category-filter))))) + (with-current-buffer + (get-buffer-create org-agenda-buffer-name) + (list `(tag . ,org-agenda-tag-filter) + `(re . ,org-agenda-regexp-filter) + `(effort . ,org-agenda-effort-filter) + `(cat . ,org-agenda-category-filter)))))) (if (org-agenda-use-sticky-p) (progn (put 'org-agenda-tag-filter :preset-filter nil) @@ -3629,13 +3660,14 @@ FILTER-ALIST is an alist of filters we need to apply when (or org-agenda-multi (org-agenda-fit-window-to-buffer)) (throw 'exit "Sticky Agenda buffer, use `r' to refresh")) (setq org-todo-keywords-for-agenda nil) - (setq org-drawers-for-agenda nil) (put 'org-agenda-tag-filter :preset-filter org-agenda-tag-filter-preset) (put 'org-agenda-category-filter :preset-filter org-agenda-category-filter-preset) (put 'org-agenda-regexp-filter :preset-filter org-agenda-regexp-filter-preset) + (put 'org-agenda-effort-filter :preset-filter + org-agenda-effort-filter-preset) (if org-agenda-multi (progn (setq buffer-read-only nil) @@ -3649,7 +3681,6 @@ FILTER-ALIST is an alist of filters we need to apply when "\n")) (narrow-to-region (point) (point-max))) (setq org-done-keywords-for-agenda nil) - ;; Setting any org variables that are in org-agenda-local-vars ;; list need to be done after the prepare call (org-agenda-prepare-window @@ -3666,7 +3697,6 @@ FILTER-ALIST is an alist of filters we need to apply when (org-uniquify org-todo-keywords-for-agenda)) (setq org-done-keywords-for-agenda (org-uniquify org-done-keywords-for-agenda)) - (setq org-drawers-for-agenda (org-uniquify org-drawers-for-agenda)) (setq org-agenda-last-prefix-arg current-prefix-arg) (setq org-agenda-this-buffer-name org-agenda-buffer-name) (and name (not org-agenda-name) @@ -3733,10 +3763,10 @@ FILTER-ALIST is an alist of filters we need to apply when (org-agenda-filter-top-headline-apply org-agenda-top-headline-filter)) (when org-agenda-tag-filter - (org-agenda-filter-apply org-agenda-tag-filter 'tag)) + (org-agenda-filter-apply org-agenda-tag-filter 'tag t)) (when (get 'org-agenda-tag-filter :preset-filter) (org-agenda-filter-apply - (get 'org-agenda-tag-filter :preset-filter) 'tag)) + (get 'org-agenda-tag-filter :preset-filter) 'tag t)) (when org-agenda-category-filter (org-agenda-filter-apply org-agenda-category-filter 'category)) (when (get 'org-agenda-category-filter :preset-filter) @@ -3747,6 +3777,11 @@ FILTER-ALIST is an alist of filters we need to apply when (when (get 'org-agenda-regexp-filter :preset-filter) (org-agenda-filter-apply (get 'org-agenda-regexp-filter :preset-filter) 'regexp)) + (when org-agenda-effort-filter + (org-agenda-filter-apply org-agenda-effort-filter 'effort)) + (when (get 'org-agenda-effort-filter :preset-filter) + (org-agenda-filter-apply + (get 'org-agenda-effort-filter :preset-filter) 'effort)) (org-add-hook 'kill-buffer-hook 'org-agenda-reset-markers 'append 'local))))) (defun org-agenda-mark-clocking-task () @@ -3782,7 +3817,7 @@ FILTER-ALIST is an alist of filters we need to apply when "Make highest priority lines bold, and lowest italic." (interactive) (mapc (lambda (o) (if (eq (overlay-get o 'org-type) 'org-priority) - (delete-overlay o))) + (delete-overlay o))) (overlays-in (point-min) (point-max))) (save-excursion (let (b e p ov h l) @@ -3800,16 +3835,17 @@ FILTER-ALIST is an alist of filters we need to apply when ov (make-overlay b e)) (overlay-put ov 'face - (cons (cond ((org-face-from-face-or-color - 'priority nil - (cdr (assoc p org-priority-faces)))) - ((and (listp org-agenda-fontify-priorities) - (org-face-from-face-or-color - 'priority nil - (cdr (assoc p org-agenda-fontify-priorities))))) - ((equal p l) 'italic) - ((equal p h) 'bold)) - 'org-priority)) + (let ((special-face + (cond ((org-face-from-face-or-color + 'priority nil + (cdr (assoc p org-priority-faces)))) + ((and (listp org-agenda-fontify-priorities) + (org-face-from-face-or-color + 'priority nil + (cdr (assoc p org-agenda-fontify-priorities))))) + ((equal p l) 'italic) + ((equal p h) 'bold)))) + (if special-face (list special-face 'org-priority) 'org-priority))) (overlay-put ov 'org-type 'org-priority))))) (defvar org-depend-tag-blocked) @@ -3847,8 +3883,7 @@ dimming them." e (point-at-eol) ov (make-overlay b e)) (if invis1 - (progn (overlay-put ov 'invisible t) - (overlay-put ov 'intangible t)) + (overlay-put ov 'invisible t) (overlay-put ov 'face 'org-agenda-dimmed-todo-face)) (overlay-put ov 'org-type 'org-blocked-todo)))))) (when (org-called-interactively-p 'interactive) @@ -3908,9 +3943,9 @@ functions do." (defun org-agenda-new-marker (&optional pos) "Return a new agenda marker. -Org-mode keeps a list of these markers and resets them when they are -no longer in use." - (let ((m (copy-marker (or pos (point))))) +Maker is at point, or at POS if non-nil. Org mode keeps a list of +these markers and resets them when they are no longer in use." + (let ((m (copy-marker (or pos (point)) t))) (setq org-agenda-last-marker-time (org-float-time)) (if org-agenda-buffer (with-current-buffer org-agenda-buffer @@ -4444,7 +4479,7 @@ in `org-agenda-text-search-extra-files'." (full-words org-agenda-search-view-force-full-words) (org-agenda-text-search-extra-files org-agenda-text-search-extra-files) regexp rtn rtnall files file pos inherited-tags - marker category category-pos level tags c neg re boolean + marker category level tags c neg re boolean ee txt beg end words regexps+ regexps- hdl-only buffer beg1 str) (unless (and (not edit-at) (stringp string) @@ -4610,7 +4645,6 @@ in `org-agenda-text-search-extra-files'." (setq marker (org-agenda-new-marker (point)) category (org-get-category) level (make-string (org-reduced-level (org-outline-level)) ? ) - category-pos (get-text-property (point) 'org-category-position) inherited-tags (or (eq org-agenda-show-inherited-tags 'always) (and (listp org-agenda-show-inherited-tags) @@ -4629,8 +4663,7 @@ in `org-agenda-text-search-extra-files'." 'org-todo-regexp org-todo-regexp 'level level 'org-complex-heading-regexp org-complex-heading-regexp - 'priority 1000 'org-category category - 'org-category-position category-pos + 'priority 1000 'type "search") (push txt ee) (goto-char (1- end)))))))))) @@ -5331,6 +5364,40 @@ the documentation of `org-diary'." (defvar org-heading-keyword-regexp-format) ; defined in org.el (defvar org-agenda-sorting-strategy-selected nil) +(defun org-agenda-entry-get-agenda-timestamp (pom) + "Retrieve timestamp information for sorting agenda views. +Given a point or marker POM, returns a cons cell of the timestamp +and the timestamp type relevant for the sorting strategy in +`org-agenda-sorting-strategy-selected'." + (let (ts ts-date-type) + (save-match-data + (cond ((org-em 'scheduled-up 'scheduled-down + org-agenda-sorting-strategy-selected) + (setq ts (org-entry-get pom "SCHEDULED") + ts-date-type " scheduled")) + ((org-em 'deadline-up 'deadline-down + org-agenda-sorting-strategy-selected) + (setq ts (org-entry-get pom "DEADLINE") + ts-date-type " deadline")) + ((org-em 'ts-up 'ts-down + org-agenda-sorting-strategy-selected) + (setq ts (org-entry-get pom "TIMESTAMP") + ts-date-type " timestamp")) + ((org-em 'tsia-up 'tsia-down + org-agenda-sorting-strategy-selected) + (setq ts (org-entry-get pom "TIMESTAMP_IA") + ts-date-type " timestamp_ia")) + ((org-em 'timestamp-up 'timestamp-down + org-agenda-sorting-strategy-selected) + (setq ts (or (org-entry-get pom "SCHEDULED") + (org-entry-get pom "DEADLINE") + (org-entry-get pom "TIMESTAMP") + (org-entry-get pom "TIMESTAMP_IA")) + ts-date-type "")) + (t (setq ts-date-type ""))) + (cons (when ts (ignore-errors (org-time-string-to-absolute ts))) + ts-date-type)))) + (defun org-agenda-get-todos () "Return the TODO information for agenda display." (let* ((props (list 'face nil @@ -5355,7 +5422,8 @@ the documentation of `org-diary'." "|") "\\|") "\\)")) (t org-not-done-regexp)))) - marker priority category category-pos level tags todo-state ts-date ts-date-type + marker priority category level tags todo-state + ts-date ts-date-type ts-date-pair ee txt beg end inherited-tags todo-state-end-pos) (goto-char (point-min)) (while (re-search-forward regexp nil t) @@ -5375,36 +5443,10 @@ the documentation of `org-diary'." (goto-char (match-beginning 2)) (setq marker (org-agenda-new-marker (match-beginning 0)) category (org-get-category) - ts-date (let (ts) - (save-match-data - (cond ((org-em 'scheduled-up 'scheduled-down - org-agenda-sorting-strategy-selected) - (setq ts (org-entry-get (point) "SCHEDULED") - ts-date-type " scheduled")) - ((org-em 'deadline-up 'deadline-down - org-agenda-sorting-strategy-selected) - (setq ts (org-entry-get (point) "DEADLINE") - ts-date-type " deadline")) - ((org-em 'ts-up 'ts-down - org-agenda-sorting-strategy-selected) - (setq ts (org-entry-get (point) "TIMESTAMP") - ts-date-type " timestamp")) - ((org-em 'tsia-up 'tsia-down - org-agenda-sorting-strategy-selected) - (setq ts (org-entry-get (point) "TIMESTAMP_IA") - ts-date-type " timestamp_ia")) - ((org-em 'timestamp-up 'timestamp-down - org-agenda-sorting-strategy-selected) - (setq ts (or (org-entry-get (point) "SCHEDULED") - (org-entry-get (point) "DEADLINE") - (org-entry-get (point) "TIMESTAMP") - (org-entry-get (point) "TIMESTAMP_IA")) - ts-date-type "")) - (t (setq ts-date-type ""))) - (when ts (ignore-errors (org-time-string-to-absolute ts))))) - category-pos (get-text-property (point) 'org-category-position) - txt (org-trim - (buffer-substring (match-beginning 2) (match-end 0))) + ts-date-pair (org-agenda-entry-get-agenda-timestamp (point)) + ts-date (car ts-date-pair) + ts-date-type (cdr ts-date-pair) + txt (org-trim (buffer-substring (match-beginning 2) (match-end 0))) inherited-tags (or (eq org-agenda-show-inherited-tags 'always) (and (listp org-agenda-show-inherited-tags) @@ -5418,10 +5460,9 @@ the documentation of `org-diary'." priority (1+ (org-get-priority txt))) (org-add-props txt props 'org-marker marker 'org-hd-marker marker - 'priority priority 'org-category category + 'priority priority 'level level 'ts-date ts-date - 'org-category-position category-pos 'type (concat "todo" ts-date-type) 'todo-state todo-state) (push txt ee) (if org-agenda-todo-list-sublevels @@ -5540,7 +5581,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines', "\\|\\(<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[hdwmy]>\\)" "\\|\\(<%%\\(([^>\n]+)\\)>\\)")) marker hdmarker deadlinep scheduledp clockp closedp inactivep - donep tmp priority category category-pos level ee txt timestr tags + donep tmp priority category level ee txt timestr tags b0 b3 e3 head todo-state end-of-match show-all warntime habitp inherited-tags ts-date) (goto-char (point-min)) @@ -5584,8 +5625,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines', ;; substring should only run to end of time stamp (setq timestr (substring timestr 0 (match-end 0)))) (setq marker (org-agenda-new-marker b0) - category (org-get-category b0) - category-pos (get-text-property b0 'org-category-position)) + category (org-get-category b0)) (save-excursion (if (not (re-search-backward org-outline-regexp-bol nil t)) (throw :skip nil) @@ -5612,11 +5652,10 @@ This function is invoked if `org-agenda-todo-ignore-deadlines', (setq priority (org-get-priority txt)) (org-add-props txt props 'priority priority 'org-marker marker 'org-hd-marker hdmarker - 'org-category category 'date date + 'date date 'level level 'ts-date (ignore-errors (org-time-string-to-absolute timestr)) - 'org-category-position category-pos 'todo-state todo-state 'warntime warntime 'type "timestamp") @@ -5635,7 +5674,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines', (format "mouse-2 or RET jump to org file %s" (abbreviate-file-name buffer-file-name)))) (regexp "^&?%%(") - marker category extra category-pos level ee txt tags entry + marker category extra level ee txt tags entry result beg b sexp sexp-entry todo-state warntime inherited-tags) (goto-char (point-min)) (while (re-search-forward regexp nil t) @@ -5654,7 +5693,6 @@ This function is invoked if `org-agenda-todo-ignore-deadlines', (setq marker (org-agenda-new-marker beg) level (make-string (org-reduced-level (org-outline-level)) ? ) category (org-get-category beg) - category-pos (get-text-property beg 'org-category-position) inherited-tags (or (eq org-agenda-show-inherited-tags 'always) (and (listp org-agenda-show-inherited-tags) @@ -5679,10 +5717,8 @@ This function is invoked if `org-agenda-todo-ignore-deadlines', (setq txt "SEXP entry returned empty string")) (setq txt (org-agenda-format-item extra txt level category tags 'time)) (org-add-props txt props 'org-marker marker - 'org-category category 'date date 'todo-state todo-state - 'org-category-position category-pos - 'level level - 'type "sexp" 'warntime warntime) + 'date date 'todo-state todo-state + 'level level 'type "sexp" 'warntime warntime) (push txt ee))))) (nreverse ee))) @@ -5712,7 +5748,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines', (let ((calendar-date-style 'european) (european-calendar-style t)) (diary-date day month year mark)))) -;; Define the` org-class' function +;; Define the `org-class' function (defun org-class (y1 m1 d1 y2 m2 d2 dayname &rest skip-weeks) "Entry applies if date is between dates on DAYNAME, but skips SKIP-WEEKS. DAYNAME is a number between 0 (Sunday) and 6 (Saturday). @@ -5791,7 +5827,7 @@ please use `org-class' instead." (list 0 0 0 (nth 1 date) (car date) (nth 2 date)))) 1 11)))) (org-agenda-search-headline-for-time nil) - marker hdmarker priority category category-pos level tags closedp + marker hdmarker priority category level tags closedp statep clockp state ee txt extra timestr rest clocked inherited-tags) (goto-char (point-min)) (while (re-search-forward regexp nil t) @@ -5803,7 +5839,6 @@ please use `org-class' instead." clockp (not (or closedp statep)) state (and statep (match-string 2)) category (org-get-category (match-beginning 0)) - category-pos (get-text-property (match-beginning 0) 'org-category-position) timestr (buffer-substring (match-beginning 0) (point-at-eol))) (when (string-match "\\]" timestr) ;; substring should only run to end of time stamp @@ -5855,9 +5890,7 @@ please use `org-class' instead." (setq priority 100000) (org-add-props txt props 'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done - 'priority priority 'org-category category - 'org-category-position category-pos - 'level level + 'priority priority 'level level 'type "closed" 'date date 'undone-face 'org-warning 'done-face 'org-agenda-done) (push txt ee)) @@ -6003,7 +6036,7 @@ specification like [h]h:mm." (dl0 (car org-agenda-deadline-leaders)) (dl1 (nth 1 org-agenda-deadline-leaders)) (dl2 (or (nth 2 org-agenda-deadline-leaders) dl1)) - d2 diff dfrac wdays pos pos1 category category-pos level + d2 diff dfrac wdays pos pos1 category level tags suppress-prewarning ee txt head face s todo-state show-all upcomingp donep timestr warntime inherited-tags ts-date) (goto-char (point-min)) @@ -6063,8 +6096,7 @@ specification like [h]h:mm." (not (= diff 0)))) (setq txt nil) (setq category (org-get-category) - warntime (get-text-property (point) 'org-appt-warntime) - category-pos (get-text-property (point) 'org-category-position)) + warntime (get-text-property (point) 'org-appt-warntime)) (if (not (re-search-backward "^\\*+[ \t]+" nil t)) (throw :skip nil) (goto-char (match-end 0)) @@ -6109,8 +6141,6 @@ specification like [h]h:mm." 'org-hd-marker (org-agenda-new-marker pos1) 'priority (+ (- diff) (org-get-priority txt)) - 'org-category category - 'org-category-position category-pos 'todo-state todo-state 'type (if upcomingp "upcoming-deadline" "deadline") 'date (if upcomingp date d2) @@ -6150,7 +6180,7 @@ an hour specification like [h]h:mm." 0 'org-hd-marker a)) (cons (marker-position mm) a))) deadline-results)) - d2 diff pos pos1 category category-pos level tags donep + d2 diff pos pos1 category level tags donep ee txt head pastschedp todo-state face timestr s habitp show-all did-habit-check-p warntime inherited-tags ts-date suppress-delay ddays) @@ -6229,8 +6259,7 @@ an hour specification like [h]h:mm." (setq habitp (if did-habit-check-p habitp (and (functionp 'org-is-habit-p) (org-is-habit-p)))) - (setq category (org-get-category) - category-pos (get-text-property (point) 'org-category-position)) + (setq category (org-get-category)) (if (and (eq org-agenda-skip-scheduled-if-deadline-is-shown 'repeated-after-deadline) (org-get-deadline-time (point)) @@ -6298,8 +6327,6 @@ an hour specification like [h]h:mm." 'priority (if habitp (org-habit-get-priority habitp) (+ 94 (- 5 diff) (org-get-priority txt))) - 'org-category category - 'category-position category-pos 'org-habit-p habitp 'todo-state todo-state) (push txt ee)))))) @@ -6317,7 +6344,7 @@ an hour specification like [h]h:mm." (abbreviate-file-name buffer-file-name)))) (regexp org-tr-regexp) (d0 (calendar-absolute-from-gregorian date)) - marker hdmarker ee txt d1 d2 s1 s2 category category-pos + marker hdmarker ee txt d1 d2 s1 s2 category level todo-state tags pos head donep inherited-tags) (goto-char (point-min)) (while (re-search-forward regexp nil t) @@ -6338,9 +6365,8 @@ an hour specification like [h]h:mm." (setq donep (member todo-state org-done-keywords)) (if (and donep org-agenda-skip-timestamp-if-done) (throw :skip t)) - (setq marker (org-agenda-new-marker (point))) - (setq category (org-get-category) - category-pos (get-text-property (point) 'org-category-position)) + (setq marker (org-agenda-new-marker (point)) + category (org-get-category)) (if (not (re-search-backward org-outline-regexp-bol nil t)) (throw :skip nil) (goto-char (match-beginning 0)) @@ -6382,8 +6408,7 @@ an hour specification like [h]h:mm." 'type "block" 'date date 'level level 'todo-state todo-state - 'priority (org-get-priority txt) 'org-category category - 'org-category-position category-pos) + 'priority (org-get-priority txt)) (push txt ee)))) (goto-char pos))) ;; Sort the entries by expiration date. @@ -6454,9 +6479,6 @@ Any match of REMOVE-RE will be removed from TXT." org-agenda-hide-tags-regexp)) (let* ((category (or category - (if (stringp org-category) - org-category - (and org-category (symbol-name org-category))) (if buffer-file-name (file-name-sans-extension (file-name-nondirectory buffer-file-name)) @@ -6465,15 +6487,17 @@ Any match of REMOVE-RE will be removed from TXT." (category-icon (if category-icon (propertize " " 'display category-icon) "")) + (effort (and (not (string= txt "")) + (get-text-property 1 'effort txt))) ;; time, tag, effort are needed for the eval of the prefix format (tag (if tags (nth (1- (length tags)) tags) "")) - time effort neffort + time (ts (if dotime (concat (if (stringp dotime) dotime "") (and org-agenda-search-headline-for-time txt)))) (time-of-day (and dotime (org-get-time-of-day ts))) stamp plain s0 s1 s2 rtn srp l - duration thecategory breadcrumbs) + duration breadcrumbs) (and (derived-mode-p 'org-mode) buffer-file-name (add-to-list 'org-agenda-contributing-files buffer-file-name)) (when (and dotime time-of-day) @@ -6524,16 +6548,6 @@ Any match of REMOVE-RE will be removed from TXT." (concat (make-string (max (- 50 (length txt)) 1) ?\ ) (match-string 2 txt)) t t txt)))) - (when (derived-mode-p 'org-mode) - (setq effort (ignore-errors (get-text-property 0 'org-effort txt)))) - - ;; org-agenda-add-time-grid-maybe calls us with *Agenda* as - ;; current buffer, so move this check outside of above - (if effort - (setq neffort (org-duration-string-to-minutes effort) - effort (setq effort (concat "[" effort "]"))) - ;; prevent erroring out with %e format when there is no effort - (setq effort "")) (when remove-re (while (string-match remove-re txt) @@ -6560,7 +6574,6 @@ Any match of REMOVE-RE will be removed from TXT." (t "")) extra (or (and (not habitp) extra) "") category (if (symbolp category) (symbol-name category) category) - thecategory (copy-sequence category) level (or level "")) (if (string-match org-bracket-link-regexp category) (progn @@ -6581,14 +6594,12 @@ Any match of REMOVE-RE will be removed from TXT." ;; And finally add the text properties (remove-text-properties 0 (length rtn) '(line-prefix t wrap-prefix t) rtn) (org-add-props rtn nil - 'org-category (if thecategory (downcase thecategory) category) + 'org-category category 'tags (mapcar 'org-downcase-keep-props tags) 'org-highest-priority org-highest-priority 'org-lowest-priority org-lowest-priority 'time-of-day time-of-day 'duration duration - 'effort effort - 'effort-minutes neffort 'breadcrumbs breadcrumbs 'txt txt 'level level @@ -6642,7 +6653,7 @@ The modified list may contain inherited tags, and tags matched by LIST is the list of agenda items formatted by `org-agenda-list'. NDAYS is the span of the current agenda view. -TODAYP is `t' when the current agenda view is on today." +TODAYP is t when the current agenda view is on today." (catch 'exit (cond ((not org-agenda-use-time-grid) (throw 'exit list)) ((and todayp (member 'today (car org-agenda-time-grid)))) @@ -6724,10 +6735,13 @@ and stored in the variable `org-prefix-format-compiled'." (setq varform `(format ,f (org-eval ,(read (match-string 4 s))))) (if opt (setq varform - `(if (equal "" ,var) + `(if (or (equal "" ,var) (equal nil ,var)) "" - (format ,f (if (equal "" ,var) "" (concat ,var ,c))))) - (setq varform `(format ,f (if (equal ,var "") "" (concat ,var ,c (get-text-property 0 'extra-space ,var))))))) + (format ,f (concat ,var ,c)))) + (setq varform + `(format ,f (if (or (equal ,var "") + (equal ,var nil)) "" + (concat ,var ,c (get-text-property 0 'extra-space ,var))))))) (setq s (replace-match "%s" t nil s)) (push varform vars)) (setq vars (nreverse vars)) @@ -6814,7 +6828,7 @@ The optional argument TYPE tells the agenda type." (t org-agenda-max-tags))) (max-entries (cond ((listp org-agenda-max-entries) (cdr (assoc type org-agenda-max-entries))) - (t org-agenda-max-entries))) l) + (t org-agenda-max-entries)))) (when org-agenda-before-sorting-filter-function (setq list (delq nil @@ -6824,7 +6838,9 @@ The optional argument TYPE tells the agenda type." list (mapcar 'identity (sort list 'org-entries-lessp))) (when max-effort (setq list (org-agenda-limit-entries - list 'effort-minutes max-effort 'identity))) + list 'effort-minutes max-effort + (lambda (e) (or e (if org-sort-agenda-noeffort-is-high + 32767 -1)))))) (when max-todo (setq list (org-agenda-limit-entries list 'todo-state max-todo))) (when max-tags @@ -6842,26 +6858,39 @@ The optional argument TYPE tells the agenda type." (delq nil (mapcar (lambda (e) - (let ((pval (funcall fun (get-text-property 1 prop e)))) + (let ((pval (funcall + fun (get-text-property (1- (length e)) + prop e)))) (if pval (setq lim (+ lim pval))) (cond ((and pval (<= lim (abs limit))) e) ((and include (not pval)) e)))) list))) list))) -(defun org-agenda-limit-interactively () +(defun org-agenda-limit-interactively (remove) "In agenda, interactively limit entries to various maximums." - (interactive) - (let* ((max (read-char "Number of [e]ntries [t]odos [T]ags [E]ffort? ")) - (num (string-to-number (read-from-minibuffer "How many? ")))) - (cond ((equal max ?e) - (let ((org-agenda-max-entries num)) (org-agenda-redo))) - ((equal max ?t) - (let ((org-agenda-max-todos num)) (org-agenda-redo))) - ((equal max ?T) - (let ((org-agenda-max-tags num)) (org-agenda-redo))) - ((equal max ?E) - (let ((org-agenda-max-effort num)) (org-agenda-redo))))) + (interactive "P") + (if remove + (progn (setq org-agenda-max-entries nil + org-agenda-max-todos nil + org-agenda-max-tags nil + org-agenda-max-effort nil) + (org-agenda-redo)) + (let* ((max (read-char "Number of [e]ntries [t]odos [T]ags [E]ffort? ")) + (msg (cond ((= max ?E) "How many minutes? ") + ((= max ?e) "How many entries? ") + ((= max ?t) "How many TODO entries? ") + ((= max ?T) "How many tagged entries? ") + (t (user-error "Wrong input")))) + (num (string-to-number (read-from-minibuffer msg)))) + (cond ((equal max ?e) + (let ((org-agenda-max-entries num)) (org-agenda-redo))) + ((equal max ?t) + (let ((org-agenda-max-todos num)) (org-agenda-redo))) + ((equal max ?T) + (let ((org-agenda-max-tags num)) (org-agenda-redo))) + ((equal max ?E) + (let ((org-agenda-max-effort num)) (org-agenda-redo)))))) (org-agenda-fit-window-to-buffer)) (defun org-agenda-highlight-todo (x) @@ -6907,25 +6936,25 @@ The optional argument TYPE tells the agenda type." (substring x (match-end 3))))))) x))) -(defsubst org-cmp-priority (a b) - "Compare the priorities of string A and B." - (let ((pa (or (get-text-property 1 'priority a) 0)) - (pb (or (get-text-property 1 'priority b) 0))) +(defsubst org-cmp-values (a b property) + "Compare the numeric value of text PROPERTY for string A and B." + (let ((pa (or (get-text-property (1- (length a)) property a) 0)) + (pb (or (get-text-property (1- (length b)) property b) 0))) (cond ((> pa pb) +1) ((< pa pb) -1)))) (defsubst org-cmp-effort (a b) "Compare the effort values of string A and B." (let* ((def (if org-sort-agenda-noeffort-is-high 32767 -1)) - (ea (or (get-text-property 1 'effort-minutes a) def)) - (eb (or (get-text-property 1 'effort-minutes b) def))) + (ea (or (get-text-property (1- (length a)) 'effort-minutes a) def)) + (eb (or (get-text-property (1- (length b)) 'effort-minutes b) def))) (cond ((> ea eb) +1) ((< ea eb) -1)))) (defsubst org-cmp-category (a b) "Compare the string values of categories of strings A and B." - (let ((ca (or (get-text-property 1 'org-category a) "")) - (cb (or (get-text-property 1 'org-category b) ""))) + (let ((ca (or (get-text-property (1- (length a)) 'org-category a) "")) + (cb (or (get-text-property (1- (length b)) 'org-category b) ""))) (cond ((string-lessp ca cb) -1) ((string-lessp cb ca) +1)))) @@ -7035,8 +7064,11 @@ their type." (time-up (and (org-em 'time-up 'time-down ss) (org-cmp-time a b))) (time-down (if time-up (- time-up) nil)) + (stats-up (and (org-em 'stats-up 'stats-down ss) + (org-cmp-values a b 'org-stats))) + (stats-down (if stats-up (- stats-up) nil)) (priority-up (and (org-em 'priority-up 'priority-down ss) - (org-cmp-priority a b))) + (org-cmp-values a b 'priority))) (priority-down (if priority-up (- priority-up) nil)) (effort-up (and (org-em 'effort-up 'effort-down ss) (org-cmp-effort a b))) @@ -7086,6 +7118,7 @@ Restriction will be the file if TYPE is `file', or if type is the universal prefix '(4), or if the cursor is before the first headline in the file. Otherwise, restriction will be to the current subtree." (interactive "P") + (org-agenda-remove-restriction-lock 'noupdate) (and (equal type '(4)) (setq type 'file)) (setq type (cond (type type) @@ -7161,69 +7194,65 @@ Allowed types are 'agenda 'timeline 'todo 'tags 'search." nil)))) (defun org-agenda-Quit () - "Exit the agenda and kill buffers loaded by `org-agenda'. -Also restore the window configuration." + "Exit the agenda, killing the agenda buffer. +Like `org-agenda-quit', but kill the buffer even when +`org-agenda-sticky' is non-nil." (interactive) - (if org-agenda-columns-active - (org-columns-quit) - (let ((buf (current-buffer))) - (if (eq org-agenda-window-setup 'other-frame) - (progn - (org-agenda-reset-markers) - (kill-buffer buf) - (org-columns-remove-overlays) - (setq org-agenda-archives-mode nil) - (delete-frame)) - (and (not (eq org-agenda-window-setup 'current-window)) - (not (one-window-p)) - (delete-window)) - (org-agenda-reset-markers) - (kill-buffer buf) - (org-columns-remove-overlays) - (setq org-agenda-archives-mode nil))) - (setq org-agenda-buffer nil) - ;; Maybe restore the pre-agenda window configuration. - (and org-agenda-restore-windows-after-quit - (not (eq org-agenda-window-setup 'other-frame)) - org-agenda-pre-window-conf - (set-window-configuration org-agenda-pre-window-conf) - (setq org-agenda-pre-window-conf nil)))) + (org-agenda--quit)) (defun org-agenda-quit () - "Exit the agenda and restore the window configuration. -When `org-agenda-sticky' is non-nil, only bury the agenda." + "Exit the agenda. + +When `org-agenda-sticky' is non-nil, bury the agenda buffer +instead of killing it. + +When `org-agenda-restore-windows-after-quit' is non-nil, restore +the pre-agenda window configuration. + +When column view is active, exit column view instead of the +agenda." (interactive) - (if (and (eq org-indirect-buffer-display 'other-window) - org-last-indirect-buffer) - (let ((org-last-indirect-window - (get-buffer-window org-last-indirect-buffer))) - (if org-last-indirect-window - (delete-window org-last-indirect-window)))) + (org-agenda--quit org-agenda-sticky)) + +(defun org-agenda--quit (&optional bury) (if org-agenda-columns-active (org-columns-quit) - (if org-agenda-sticky - (let ((buf (current-buffer))) - (if (eq org-agenda-window-setup 'other-frame) - (progn - (delete-frame)) - (and (not (eq org-agenda-window-setup 'current-window)) - (not (one-window-p)) - (delete-window))) - (with-current-buffer buf - (bury-buffer) - ;; Maybe restore the pre-agenda window configuration. - (and org-agenda-restore-windows-after-quit - (not (eq org-agenda-window-setup 'other-frame)) - org-agenda-pre-window-conf - (set-window-configuration org-agenda-pre-window-conf) - (setq org-agenda-pre-window-conf nil)))) - (org-agenda-Quit)))) + (let ((buf (current-buffer)) + (wconf org-agenda-pre-window-conf) + (org-agenda-last-indirect-window + (and (eq org-indirect-buffer-display 'other-window) + org-agenda-last-indirect-buffer + (get-buffer-window org-agenda-last-indirect-buffer)))) + (cond + ((eq org-agenda-window-setup 'other-frame) + (delete-frame)) + ((and org-agenda-restore-windows-after-quit + wconf) + ;; Maybe restore the pre-agenda window configuration. Reset + ;; `org-agenda-pre-window-conf' before running + ;; `set-window-configuration', which loses the current buffer. + (setq org-agenda-pre-window-conf nil) + (set-window-configuration wconf)) + (t + (when org-agenda-last-indirect-window + (delete-window org-agenda-last-indirect-window)) + (and (not (eq org-agenda-window-setup 'current-window)) + (not (one-window-p)) + (delete-window)))) + (if bury + (bury-buffer buf) + (kill-buffer buf) + (setq org-agenda-archives-mode nil + org-agenda-buffer nil))))) (defun org-agenda-exit () - "Exit the agenda and restore the window configuration. -Also kill Org-mode buffers loaded by `org-agenda'. Org-mode -buffers visited directly by the user will not be touched." + "Exit the agenda, killing Org buffers loaded by the agenda. +Like `org-agenda-Quit', but kill any buffers that were created by +the agenda. Org buffers visited directly by the user will not be +touched. Also, exit the agenda even if it is in column view." (interactive) + (when org-agenda-columns-active + (org-columns-quit)) (org-release-buffers org-agenda-new-buffers) (setq org-agenda-new-buffers nil) (org-agenda-Quit)) @@ -7264,6 +7293,9 @@ in the agenda." (cat-preset (get 'org-agenda-category-filter :preset-filter)) (re-filter org-agenda-regexp-filter) (re-preset (get 'org-agenda-regexp-filter :preset-filter)) + (effort-filter org-agenda-effort-filter) + (effort-preset (get 'org-agenda-effort-filter :preset-filter)) + (org-agenda-tag-filter-while-redo (or tag-filter tag-preset)) (cols org-agenda-columns-active) (line (org-current-line)) (window-line (- line (org-current-line (window-start)))) @@ -7281,6 +7313,7 @@ in the agenda." (put 'org-agenda-tag-filter :preset-filter nil) (put 'org-agenda-category-filter :preset-filter nil) (put 'org-agenda-regexp-filter :preset-filter nil) + (put 'org-agenda-effort-filter :preset-filter nil) (and cols (org-columns-quit)) (message "Rebuilding agenda buffer...") (if series-redo-cmd @@ -7291,16 +7324,20 @@ in the agenda." org-agenda-tag-filter tag-filter org-agenda-category-filter cat-filter org-agenda-regexp-filter re-filter + org-agenda-effort-filter effort-filter org-agenda-top-headline-filter top-hl-filter) (message "Rebuilding agenda buffer...done") (put 'org-agenda-tag-filter :preset-filter tag-preset) (put 'org-agenda-category-filter :preset-filter cat-preset) (put 'org-agenda-regexp-filter :preset-filter re-preset) + (put 'org-agenda-effort-filter :preset-filter effort-preset) (let ((tag (or tag-filter tag-preset)) (cat (or cat-filter cat-preset)) - (re (or re-filter re-preset))) - (when tag (org-agenda-filter-apply tag 'tag)) + (effort (or effort-filter effort-preset)) + (re (or re-filter re-preset))) + (when tag (org-agenda-filter-apply tag 'tag t)) (when cat (org-agenda-filter-apply cat 'category)) + (when effort (org-agenda-filter-apply effort 'effort)) (when re (org-agenda-filter-apply re 'regexp))) (and top-hl-filter (org-agenda-filter-top-headline-apply top-hl-filter)) (and cols (org-called-interactively-p 'any) (org-agenda-columns)) @@ -7318,7 +7355,7 @@ The category is that of the current line." (if (and org-agenda-filtered-by-category org-agenda-category-filter) (org-agenda-filter-show-all-cat) - (let ((cat (org-no-properties (get-text-property (point) 'org-category)))) + (let ((cat (org-no-properties (org-get-at-eol 'org-category 1)))) (cond ((and cat strip) (org-agenda-filter-apply @@ -7372,6 +7409,39 @@ With two prefix arguments, remove the regexp filters." (org-agenda-filter-show-all-re) (message "Regexp filter removed"))) +(defvar org-agenda-effort-filter nil) +(defun org-agenda-filter-by-effort (strip) + "Filter agenda entries by effort. +With no prefix argument, keep entries matching the effort condition. +With one prefix argument, filter out entries matching the condition. +With two prefix arguments, remove the effort filters." + (interactive "P") + (cond ((member strip '(nil 4)) + (let ((efforts (org-split-string + (or (cdr (assoc (concat org-effort-property "_ALL") + org-global-properties)) + "0 0:10 0:30 1:00 2:00 3:00 4:00 5:00 6:00 7:00 8:00" + ""))) + (eff -1) + effort-prompt op) + (while (not (member op '(?< ?> ?=))) + (setq op (read-char-exclusive "Effort operator? (> = or <)"))) + (loop for i from 0 to 9 do + (setq effort-prompt + (concat + effort-prompt " [" + (if (= i 9) "0" (int-to-string (1+ i))) + "]" (nth i efforts)))) + (message "Effort %s%s" (char-to-string op) effort-prompt) + (while (or (< eff 0) (> eff 9)) + (setq eff (string-to-number (char-to-string (read-char-exclusive))))) + (setq org-agenda-effort-filter + (list (concat (if strip "-" "+") + (char-to-string op) (nth (1- eff) efforts)))) + (org-agenda-filter-apply org-agenda-effort-filter 'effort))) + (t (org-agenda-filter-show-all-effort) + (message "Effort filter removed")))) + (defun org-agenda-filter-remove-all () "Remove all filters from the current agenda buffer." (interactive) @@ -7383,15 +7453,21 @@ With two prefix arguments, remove the regexp filters." (org-agenda-filter-show-all-re)) (when org-agenda-top-headline-filter (org-agenda-filter-show-all-top-filter)) + (when org-agenda-effort-filter + (org-agenda-filter-show-all-effort)) (org-agenda-finalize)) -(defun org-agenda-filter-by-tag (strip &optional char narrow) +(defun org-agenda-filter-by-tag (arg &optional char exclude) "Keep only those lines in the agenda buffer that have a specific tag. -The tag is selected with its fast selection letter, as configured. -With prefix argument STRIP, remove all lines that do have the tag. -A lisp caller can specify CHAR. NARROW means that the new tag should be -used to narrow the search - the interactive user can also press `-' or `+' -to switch to narrowing." +The tag is selected with its fast selection letter, as +configured. With a single \\[universal-argument] prefix ARG, +exclude the agenda search. With a double \\[universal-argument] +prefix ARG, filter the literal tag. I.e. don't filter on all its +group members. + +A lisp caller can specify CHAR. EXCLUDE means that the new tag should be +used to exclude the search - the interactive user can also press `-' or `+' +to switch between filtering and excluding." (interactive "P") (let* ((alist org-tag-alist-for-agenda) (tag-chars (mapconcat @@ -7399,46 +7475,26 @@ to switch to narrowing." (cdr x)) (char-to-string (cdr x)) "")) - alist "")) - (efforts (org-split-string - (or (cdr (assoc (concat org-effort-property "_ALL") - org-global-properties)) - "0 0:10 0:30 1:00 2:00 3:00 4:00 5:00 6:00 7:00 8:00" - ""))) - (effort-op org-agenda-filter-effort-default-operator) - (effort-prompt "") + org-tag-alist-for-agenda "")) + (valid-char-list (append '(?\t ?\r ?/ ?. ?\s ?q) + (string-to-list tag-chars))) + (exclude (or exclude (equal arg '(4)))) + (expand (not (equal arg '(16)))) (inhibit-read-only t) (current org-agenda-tag-filter) - maybe-refresh a n tag) + a n tag) (unless char - (message - "%s by tag [%s ], [TAB], %s[/]:off, [+-]:narrow, [>=<?]:effort: " - (if narrow "Narrow" "Filter") tag-chars - (if org-agenda-auto-exclude-function "[RET], " "")) - (setq char (read-char-exclusive))) - (when (member char '(?+ ?-)) - ;; Narrowing down - (cond ((equal char ?-) (setq strip t narrow t)) - ((equal char ?+) (setq strip nil narrow t))) - (message - "Narrow by tag [%s ], [TAB], [/]:off, [>=<]:effort: " tag-chars) - (setq char (read-char-exclusive))) - (when (member char '(?< ?> ?= ??)) - ;; An effort operator - (setq effort-op (char-to-string char)) - (setq alist nil) ; to make sure it will be interpreted as effort. - (unless (equal char ??) - (loop for i from 0 to 9 do - (setq effort-prompt - (concat - effort-prompt " [" - (if (= i 9) "0" (int-to-string (1+ i))) - "]" (nth i efforts)))) - (message "Effort%s: %s " effort-op effort-prompt) + (while (not (memq char valid-char-list)) + (message + "%s by tag [%s ], [TAB], %s[/]:off, [+/-]:filter/exclude%s, [q]:quit" + (if exclude "Exclude" "Filter") tag-chars + (if org-agenda-auto-exclude-function "[RET], " "") + (if expand "" ", no grouptag expand")) (setq char (read-char-exclusive)) - (when (or (< char ?0) (> char ?9)) - (error "Need 1-9,0 to select effort")))) - (when (equal char ?\t) + ;; Excluding or filtering down + (cond ((eq char ?-) (setq exclude t)) + ((eq char ?+) (setq exclude nil))))) + (when (eq char ?\t) (unless (local-variable-p 'org-global-tags-completion-table (current-buffer)) (org-set-local 'org-global-tags-completion-table (org-global-tags-completion-table))) @@ -7446,7 +7502,7 @@ to switch to narrowing." (setq tag (org-icompleting-read "Tag: " org-global-tags-completion-table)))) (cond - ((equal char ?\r) + ((eq char ?\r) (org-agenda-filter-show-all-tag) (when org-agenda-auto-exclude-function (setq org-agenda-tag-filter nil) @@ -7455,39 +7511,27 @@ to switch to narrowing." (if modifier (push modifier org-agenda-tag-filter)))) (if (not (null org-agenda-tag-filter)) - (org-agenda-filter-apply org-agenda-tag-filter 'tag))) - (setq maybe-refresh t)) - ((equal char ?/) + (org-agenda-filter-apply org-agenda-tag-filter 'tag expand)))) + ((eq char ?/) (org-agenda-filter-show-all-tag) (when (get 'org-agenda-tag-filter :preset-filter) - (org-agenda-filter-apply org-agenda-tag-filter 'tag)) - (setq maybe-refresh t)) - ((equal char ?. ) + (org-agenda-filter-apply org-agenda-tag-filter 'tag expand))) + ((eq char ?.) (setq org-agenda-tag-filter (mapcar (lambda(tag) (concat "+" tag)) (org-get-at-bol 'tags))) - (org-agenda-filter-apply org-agenda-tag-filter 'tag) - (setq maybe-refresh t)) - ((or (equal char ?\ ) + (org-agenda-filter-apply org-agenda-tag-filter 'tag expand)) + ((eq char ?q)) ;If q, abort (even if there is a q-key for a tag...) + ((or (eq char ?\s) (setq a (rassoc char alist)) - (and (>= char ?0) (<= char ?9) - (setq n (if (= char ?0) 9 (- char ?0 1)) - tag (concat effort-op (nth n efforts)) - a (cons tag nil))) - (and (= char ??) - (setq tag "?eff") - a (cons tag nil)) (and tag (setq a (cons tag nil)))) (org-agenda-filter-show-all-tag) (setq tag (car a)) (setq org-agenda-tag-filter - (cons (concat (if strip "-" "+") tag) - (if narrow current nil))) - (org-agenda-filter-apply org-agenda-tag-filter 'tag) - (setq maybe-refresh t)) - (t (error "Invalid tag selection character %c" char))) - (when maybe-refresh - (org-agenda-redo)))) + (cons (concat (if exclude "-" "+") tag) + current)) + (org-agenda-filter-apply org-agenda-tag-filter 'tag expand)) + (t (error "Invalid tag selection character %c" char))))) (defun org-agenda-get-represented-tags () "Get a list of all tags currently represented in the agenda." @@ -7500,13 +7544,15 @@ to switch to narrowing." (get-text-property (point) 'tags)))) tags)) -(defun org-agenda-filter-by-tag-refine (strip &optional char) +(defun org-agenda-filter-by-tag-refine (arg &optional char) "Refine the current filter. See `org-agenda-filter-by-tag'." (interactive "P") - (org-agenda-filter-by-tag strip char 'refine)) + (org-agenda-filter-by-tag arg char 'refine)) -(defun org-agenda-filter-make-matcher (filter type) - "Create the form that tests a line for agenda filter." +(defun org-agenda-filter-make-matcher (filter type &optional expand) + "Create the form that tests a line for agenda filter. Optional +argument EXPAND can be used for the TYPE tag and will expand the +tags in the FILTER if any of the tags in FILTER are grouptags." (let (f f1) (cond ;; Tag filter @@ -7516,28 +7562,11 @@ to switch to narrowing." (append (get 'org-agenda-tag-filter :preset-filter) filter))) (dolist (x filter) - (let ((nfilter (org-agenda-filter-expand-tags filter)) nf nf1 - (ffunc - (lambda (nf0 nf01 fltr notgroup op) - (dolist (x fltr) - (if (member x '("-" "+")) - (setq nf01 (if (equal x "-") 'tags '(not tags))) - (if (string-match "[<=>?]" x) - (setq nf01 (org-agenda-filter-effort-form x)) - (setq nf01 (list 'member (downcase (substring x 1)) - 'tags))) - (when (equal (string-to-char x) ?-) - (setq nf01 (list 'not nf01)) - (when (not notgroup) (setq op 'and)))) - (push nf01 nf0)) - (if notgroup - (push (cons 'and nf0) f) - (push (cons (or op 'or) nf0) f))))) - (cond ((equal filter '("+")) - (setq f (list (list 'not 'tags)))) - ((equal nfilter filter) - (funcall ffunc f1 f filter t nil)) - (t (funcall ffunc nf1 nf nfilter nil nil)))))) + (let ((op (string-to-char x))) + (if expand (setq x (org-agenda-filter-expand-tags (list x) t)) + (setq x (list x))) + (setq f1 (org-agenda-filter-make-matcher-tag-exp x op)) + (push f1 f)))) ;; Category filter ((eq type 'category) (setq filter @@ -7559,9 +7588,43 @@ to switch to narrowing." (if (equal "-" (substring x 0 1)) (setq f1 (list 'not (list 'string-match (substring x 1) 'txt))) (setq f1 (list 'string-match (substring x 1) 'txt))) - (push f1 f)))) + (push f1 f))) + ;; Effort filter + ((eq type 'effort) + (setq filter + (delete-dups + (append (get 'org-agenda-effort-filter :preset-filter) + filter))) + (dolist (x filter) + (push (org-agenda-filter-effort-form x) f)))) (cons 'and (nreverse f)))) +(defun org-agenda-filter-make-matcher-tag-exp (tags op) + "Create the form that tests a line for agenda filter for +tag-expressions. Return a match-expression given TAGS. OP is an +operator of type CHAR that allows the function to set the right +switches in the returned form." + (let (f f1) ;f = return expression. f1 = working-area + (dolist (x tags) + (let* ((tag (substring x 1)) + (isregexp (and (equal "{" (substring tag 0 1)) + (equal "}" (substring tag -1)))) + regexp) + (cond + (isregexp + (setq regexp (substring tag 1 -1)) + (setq f1 (list 'org-match-any-p regexp 'tags))) + (t + (setq f1 (list 'member (downcase tag) 'tags)))) + (when (eq op ?-) + (setq f1 (list 'not f1)))) + (push f1 f)) + ;; Any of the expressions can match if op = + + ;; all must match if the operator is -. + (if (eq op ?-) + (cons 'and f) + (cons 'or f)))) + (defun org-agenda-filter-effort-form (e) "Return the form to compare the effort of the current line with what E says. E looks like \"+<2:25\"." @@ -7578,11 +7641,9 @@ E looks like \"+<2:25\"." (defun org-agenda-compare-effort (op value) "Compare the effort of the current line with VALUE, using OP. If the line does not have an effort defined, return nil." - (let ((eff (org-get-at-bol 'effort-minutes))) - (if (equal op ??) - (not eff) - (funcall op (or eff (if org-sort-agenda-noeffort-is-high 32767 0)) - value)))) + (let ((eff (org-get-at-eol 'effort-minutes 1))) + (funcall op (or eff (if org-sort-agenda-noeffort-is-high 32767 -1)) + value))) (defun org-agenda-filter-expand-tags (filter &optional no-operator) "Expand group tags in FILTER for the agenda. @@ -7602,12 +7663,14 @@ When NO-OPERATOR is non-nil, do not add the + operator to returned tags." (reverse rtn)) filter)) -(defun org-agenda-filter-apply (filter type) - "Set FILTER as the new agenda filter and apply it." +(defun org-agenda-filter-apply (filter type &optional expand) + "Set FILTER as the new agenda filter and apply it. Optional +argument EXPAND can be used for the TYPE tag and will expand the +tags in the FILTER if any of the tags in FILTER are grouptags." ;; Deactivate `org-agenda-entry-text-mode' when filtering (if org-agenda-entry-text-mode (org-agenda-entry-text-mode)) (let (tags cat txt) - (setq org-agenda-filter-form (org-agenda-filter-make-matcher filter type)) + (setq org-agenda-filter-form (org-agenda-filter-make-matcher filter type expand)) ;; Only set `org-agenda-filtered-by-category' to t when a unique ;; category is used as the filter: (setq org-agenda-filtered-by-category @@ -7619,13 +7682,9 @@ When NO-OPERATOR is non-nil, do not add the + operator to returned tags." (while (not (eobp)) (if (org-get-at-bol 'org-marker) (progn - (setq tags ; used in eval - (apply 'append - (mapcar (lambda (f) - (org-agenda-filter-expand-tags (list f) t)) - (org-get-at-bol 'tags))) - cat (get-text-property (point) 'org-category) - txt (get-text-property (point) 'txt)) + (setq tags (org-get-at-bol 'tags) + cat (org-get-at-eol 'org-category 1) + txt (org-get-at-eol 'txt 1)) (if (not (eval org-agenda-filter-form)) (org-agenda-filter-hide-line type)) (beginning-of-line 2)) @@ -7678,6 +7737,8 @@ When NO-OPERATOR is non-nil, do not add the + operator to returned tags." (org-agenda-remove-filter 'tag)) (defun org-agenda-filter-show-all-re nil (org-agenda-remove-filter 'regexp)) +(defun org-agenda-filter-show-all-effort nil + (org-agenda-remove-filter 'effort)) (defun org-agenda-filter-show-all-cat nil (org-agenda-remove-filter 'category)) (defun org-agenda-filter-show-all-top-filter nil @@ -7789,27 +7850,40 @@ Negative selection means regexp must not match for selection of an entry." (text-property-any (point-min) (point-max) 'org-today t) (text-property-any (point-min) (point-max) 'org-agenda-type 'agenda) (and (get-text-property (min (1- (point-max)) (point)) 'org-series) - (org-agenda-goto-block-beginning)) + (org-agenda-backward-block)) (point-min)))) -(defun org-agenda-goto-block-beginning () - "Go the agenda block beginning." +(defun org-agenda-backward-block () + "Move backward by one agenda block." (interactive) - (if (not (derived-mode-p 'org-agenda-mode)) - (error "Cannot execute this command outside of org-agenda-mode buffers") - (let (dest) - (save-excursion - (unless (looking-at "\\'") - (forward-char)) - (let* ((prop 'org-agenda-structural-header) - (p (previous-single-property-change (point) prop)) - (n (next-single-property-change (or (and (looking-at "\\`") 1) - (1- (point))) prop))) - (setq dest (cond ((eq n (point-at-eol)) (1- n)) (p (1- p)))))) - (if (not dest) - (error "Cannot find the beginning of the blog") - (goto-char dest) - (move-beginning-of-line 1))))) + (org-agenda-forward-block 'backward)) + +(defun org-agenda-forward-block (&optional backward) + "Move forward by one agenda block. +When optional argument BACKWARD is set, go backward" + (interactive) + (cond ((not (derived-mode-p 'org-agenda-mode)) + (user-error + "Cannot execute this command outside of org-agenda-mode buffers")) + ((looking-at (if backward "\\`" "\\'")) + (message "Already at the %s block" (if backward "first" "last"))) + (t (let ((pos (prog1 (point) + (ignore-errors (if backward (backward-char 1) + (move-end-of-line 1))))) + (f (if backward + 'previous-single-property-change + 'next-single-property-change)) + moved dest) + (while (and (setq dest (funcall + f (point) 'org-agenda-structural-header)) + (not (get-text-property + (point) 'org-agenda-structural-header))) + (setq moved t) + (goto-char dest)) + (if moved (move-beginning-of-line 1) + (goto-char (if backward (point-min) (point-max))) + (move-beginning-of-line 1) + (message "No %s block" (if backward "previous" "further"))))))) (defun org-agenda-later (arg) "Go forward in time by the current span. @@ -7985,7 +8059,7 @@ so that the date SD will be in that range." (setq y1 (org-small-year-to-year (/ n 100)) n (mod n 100))) (setq sd - (calendar-absolute-from-iso + (calendar-iso-to-absolute (list n 1 (or y1 (nth 2 (calendar-iso-from-absolute sd))))))))) ((eq span 'month) @@ -8201,6 +8275,19 @@ When called with a prefix argument, include all archive files as well." "}") 'face 'org-agenda-filter-tags 'help-echo "Tags used in filtering")) "") + (if (or org-agenda-effort-filter + (get 'org-agenda-effort-filter :preset-filter)) + '(:eval (org-propertize + (concat " {" + (mapconcat + 'identity + (append + (get 'org-agenda-effort-filter :preset-filter) + org-agenda-effort-filter) + "") + "}") + 'face 'org-agenda-filter-effort + 'help-echo "Effort conditions used in filtering")) "") (if (or org-agenda-regexp-filter (get 'org-agenda-regexp-filter :preset-filter)) '(:eval (org-propertize @@ -8287,7 +8374,7 @@ When called with a prefix argument, include all archive files as well." (message "No tags associated with this line")))) (defun org-agenda-goto (&optional highlight) - "Go to the Org-mode file which contains the item at point." + "Go to the entry at point in the corresponding Org-mode file." (interactive) (let* ((marker (or (org-get-at-bol 'org-marker) (org-agenda-error))) @@ -8305,6 +8392,9 @@ When called with a prefix argument, include all archive files as well." (when (outline-invisible-p) (show-entry)) ; display invisible text (recenter (/ (window-height) 2)) + (org-back-to-heading t) + (if (re-search-forward org-complex-heading-regexp nil t) + (goto-char (match-beginning 4))) (run-hooks 'org-agenda-after-show-hook) (and highlight (org-highlight (point-at-bol) (point-at-eol))))) @@ -8421,8 +8511,8 @@ If this information is not given, the function uses the tree at point." (defun org-agenda-refile (&optional goto rfloc no-update) "Refile the item at point. -When GOTO is 0 or '(64), clear the refile cache. -When GOTO is '(16), go to the location of the last refiled item. +When GOTO is 0 or '(64) or \\[universal-argument] \\[universal-argument] \\[universal-argument], clear the refile cache. +When GOTO is '(16) or \\[universal-argument] \\[universal-argument], go to the location of the last refiled item. RFLOC can be a refile location obtained in a different way. When NO-UPDATE is non-nil, don't redo the agenda buffer." (interactive "P") @@ -8513,10 +8603,12 @@ It also looks at the text of the entry itself." (org-agenda-error))) (buffer (marker-buffer marker)) (pos (marker-position marker))) + (unless buffer (user-error "Trying to switch to non-existent buffer")) (org-pop-to-buffer-same-window buffer) (and delete-other-windows (delete-other-windows)) (widen) (goto-char pos) + (org-back-to-heading t) (when (derived-mode-p 'org-mode) (org-show-context 'agenda) (save-excursion @@ -8538,10 +8630,8 @@ With prefix argument FULL-ENTRY, make the entire entry visible if it was hidden in the outline." (interactive "P") (let ((win (selected-window))) - (if full-entry - (let ((org-show-entry-below t)) - (org-agenda-goto t)) - (org-agenda-goto t)) + (org-agenda-goto t) + (when full-entry (org-show-entry)) (select-window win))) (defvar org-agenda-show-window nil) @@ -8612,15 +8702,10 @@ if it was hidden in the outline." (run-hook-with-args 'org-cycle-hook 'subtree)) (message "Remote: SUBTREE")) ((= more 4) - (let* ((org-drawers (delete "LOGBOOK" (copy-sequence org-drawers))) - (org-drawer-regexp - (concat "^[ \t]*:\\(" - (mapconcat 'regexp-quote org-drawers "\\|") - "\\):[ \t]*$"))) - (show-subtree) - (save-excursion - (org-back-to-heading) - (org-cycle-hide-drawers 'subtree))) + (show-subtree) + (save-excursion + (org-back-to-heading) + (org-cycle-hide-drawers 'subtree '("LOGBOOK"))) (message "Remote: SUBTREE AND LOGBOOK")) ((> more 4) (show-subtree) @@ -8630,11 +8715,12 @@ if it was hidden in the outline." (defvar org-agenda-cycle-counter nil) (defun org-agenda-cycle-show (&optional n) "Show the current entry in another window, with default settings. -Default settings are taken from `org-show-hierarchy-above' and siblings. -When use repeatedly in immediate succession, the remote entry will cycle -through visibility -children -> subtree -> folded +Default settings are taken from `org-show-context-detail'. When +use repeatedly in immediate succession, the remote entry will +cycle through visibility + + children -> subtree -> folded When called with a numeric prefix arg, that arg will be passed through to `org-agenda-show-1'. For the interpretation of that argument, see the @@ -8671,7 +8757,8 @@ docstring of `org-agenda-show-1'." (org-agenda-error))) (defun org-agenda-error () - (error "Command not allowed in this line")) + "Throw an error when a command is not allowed in the agenda." + (user-error "Command not allowed in this line")) (defun org-agenda-tree-to-indirect-buffer (arg) "Show the subtree corresponding to the current entry in an indirect buffer. @@ -8698,7 +8785,8 @@ use the dedicated frame)." (and indirect-window (select-window indirect-window)) (switch-to-buffer org-last-indirect-buffer :norecord) (fit-window-to-buffer indirect-window))) - (select-window (get-buffer-window agenda-buffer))))) + (select-window (get-buffer-window agenda-buffer)) + (setq org-agenda-last-indirect-buffer org-last-indirect-buffer)))) (defun org-agenda-do-tree-to-indirect-buffer (arg) "Same as `org-agenda-tree-to-indirect-buffer' without saving window." @@ -8770,7 +8858,8 @@ the same tree node, and the headline of the tree node in the Org-mode file." (string-match (concat "^" (regexp-opt org-done-keywords-for-agenda)) newhead) (org-agenda-unmark-clocking-task)) - (org-move-to-column col)))) + (org-move-to-column col) + (org-agenda-mark-clocking-task)))) (defun org-agenda-add-note (&optional arg) "Add a time-stamped note to the entry at point." @@ -8819,7 +8908,7 @@ If FORCE-TAGS is non nil, the car of it returns the new tags." (equal m hdmarker)) (setq props (text-properties-at (point)) dotime (org-get-at-bol 'dotime) - cat (org-get-at-bol 'org-category) + cat (org-get-at-eol 'org-category 1) level (org-get-at-bol 'level) tags thetags new @@ -9184,7 +9273,6 @@ ARG is passed through to `org-schedule'." (type (marker-insertion-type marker)) (buffer (marker-buffer marker)) (pos (marker-position marker)) - (org-insert-labeled-timestamps-at-point nil) ts) (set-marker-insertion-type marker t) (org-with-remote-undo buffer @@ -9205,7 +9293,6 @@ ARG is passed through to `org-deadline'." (org-agenda-error))) (buffer (marker-buffer marker)) (pos (marker-position marker)) - (org-insert-labeled-timestamps-at-point nil) ts) (org-with-remote-undo buffer (with-current-buffer buffer @@ -9431,33 +9518,30 @@ Add TEXT as headline, and position the cursor in the second line so that a timestamp can be added there." (widen) (goto-char (point-max)) - (or (bolp) (insert "\n")) - (insert "* " text "\n") - (if org-adapt-indentation (org-indent-to-column 2))) + (unless (bolp) (insert "\n")) + (org-insert-heading nil t t) + (insert text) + (org-end-of-meta-data) + (unless (bolp) (insert "\n")) + (when org-adapt-indentation (org-indent-to-column 2))) (defun org-agenda-insert-diary-make-new-entry (text) "Make a new entry with TEXT as the first child of the current subtree. -Position the point in the line right after the new heading so -that a timestamp can be added there." - (let ((org-show-following-heading t) - (org-show-siblings t) - (org-show-hierarchy-above t) - (org-show-entry-below t) - col) - (outline-next-heading) - (org-back-over-empty-lines) - (or (looking-at "[ \t]*$") - (progn (insert "\n") (backward-char 1))) - (org-insert-heading nil t) - (org-do-demote) - (setq col (current-column)) - (insert text "\n") - (if org-adapt-indentation (org-indent-to-column col)) - (let ((org-show-following-heading t) - (org-show-siblings t) - (org-show-hierarchy-above t) - (org-show-entry-below t)) - (org-show-context)))) +Position the point in the heading's first body line so that +a timestamp can be added there." + (outline-next-heading) + (org-back-over-empty-lines) + (unless (looking-at "[ \t]*$") (save-excursion (insert "\n"))) + (org-insert-heading nil t) + (org-do-demote) + (let ((col (current-column))) + (insert text) + (org-end-of-meta-data) + ;; Ensure point is left on a blank line, at proper indentation. + (unless (bolp) (insert "\n")) + (unless (org-looking-at-p "^[ \t]*$") (save-excursion (insert "\n"))) + (when org-adapt-indentation (org-indent-to-column col))) + (org-show-set-visibility 'lineage)) (defun org-agenda-diary-entry () "Make a diary entry, like the `i' command from the calendar. @@ -9473,13 +9557,13 @@ entries in that Org-mode file." (message "Diary entry: [d]ay [w]eekly [m]onthly [y]early [a]nniversary [b]lock [c]yclic") (read-char-exclusive))) (cmd (cdr (assoc char - '((?d . insert-diary-entry) - (?w . insert-weekly-diary-entry) - (?m . insert-monthly-diary-entry) - (?y . insert-yearly-diary-entry) - (?a . insert-anniversary-diary-entry) - (?b . insert-block-diary-entry) - (?c . insert-cyclic-diary-entry))))) + '((?d . diary-insert-entry) + (?w . diary-insert-weekly-entry) + (?m . diary-insert-monthly-entry) + (?y . diary-insert-yearly-entry) + (?a . diary-insert-anniversary-entry) + (?b . diary-insert-block-entry) + (?c . diary-insert-cyclic-entry))))) (oldf (symbol-function 'calendar-cursor-to-date)) ;; (buf (get-file-buffer (substitute-in-file-name diary-file))) (point (point)) @@ -9530,12 +9614,12 @@ entries in that Org-mode file." (defun org-agenda-phases-of-moon () "Display the phases of the moon for the 3 months around the cursor date." (interactive) - (org-agenda-execute-calendar-command 'calendar-phases-of-moon)) + (org-agenda-execute-calendar-command 'calendar-lunar-phases)) (defun org-agenda-holidays () "Display the holidays for the 3 months around the cursor date." (interactive) - (org-agenda-execute-calendar-command 'list-calendar-holidays)) + (org-agenda-execute-calendar-command 'calendar-list-holidays)) (defvar calendar-longitude) ; defined in calendar.el (defvar calendar-latitude) ; defined in calendar.el @@ -9572,9 +9656,13 @@ argument, latitude and longitude will be prompted for." "Compute the Org-mode agenda for the calendar date displayed at the cursor. This is a command that has to be installed in `calendar-mode-map'." (interactive) - (org-agenda-list nil (calendar-absolute-from-gregorian - (calendar-cursor-to-date)) - nil)) + ;; Temporarily disable sticky agenda since user clearly wants to + ;; refresh view anyway. + (let ((org-agenda-buffer-tmp-name "*Org Agenda(a)*") + (org-agenda-sticky nil)) + (org-agenda-list nil (calendar-absolute-from-gregorian + (calendar-cursor-to-date)) + nil))) (defun org-agenda-convert-date () (interactive) @@ -9871,6 +9959,11 @@ The prefix arg is passed through to the command if possible." (goto-char pos) (let (org-loop-over-headlines-in-active-region) (eval cmd)) + ;; `post-command-hook' is not run yet. We make sure any + ;; pending log note is processed. + (when (or (memq 'org-add-log-note (default-value 'post-command-hook)) + (memq 'org-add-log-note post-command-hook)) + (org-add-log-note)) (setq cnt (1+ cnt)))) (when redo-at-end (org-agenda-redo)) (unless org-agenda-persistent-marks @@ -9900,12 +9993,14 @@ current HH:MM time." (defun org-agenda-reapply-filters () "Re-apply all agenda filters." (mapcar - (lambda(f) (when (car f) (org-agenda-filter-apply (car f) (cadr f)))) + (lambda(f) (when (car f) (org-agenda-filter-apply (car f) (cadr f) t))) `((,org-agenda-tag-filter tag) (,org-agenda-category-filter category) (,org-agenda-regexp-filter regexp) + (,org-agenda-effort-filter effort) (,(get 'org-agenda-tag-filter :preset-filter) tag) (,(get 'org-agenda-category-filter :preset-filter) category) + (,(get 'org-agenda-effort-filter :preset-filter) effort) (,(get 'org-agenda-regexp-filter :preset-filter) regexp)))) (defun org-agenda-drag-line-forward (arg &optional backward) @@ -10050,7 +10145,7 @@ to override `appt-message-warning-time'." (replace-regexp-in-string org-bracket-link-regexp "\\3" (or (get-text-property 1 'txt x) "")))) - (cat (get-text-property 1 'org-category x)) + (cat (get-text-property (1- (length x)) 'org-category x)) (tod (get-text-property 1 'time-of-day x)) (ok (or (null filter) (and (stringp filter) (string-match filter evt)) @@ -10090,7 +10185,8 @@ to override `appt-message-warning-time'." (defun org-agenda-todo-yesterday (&optional arg) "Like `org-agenda-todo' but the time of change will be 23:59 of yesterday." (interactive "P") - (let* ((hour (third (decode-time + (let* ((org-use-effective-time t) + (hour (third (decode-time (org-current-time)))) (org-extend-today-until (1+ hour))) (org-agenda-todo arg))) diff --git a/lisp/org-archive.el b/lisp/org-archive.el index 6deac47..bbe95ed 100644 --- a/lisp/org-archive.el +++ b/lisp/org-archive.el @@ -119,9 +119,15 @@ information." (const :tag "Outline path" olpath) (const :tag "Local tags" ltags))) +(defvar org-archive-hook nil + "Hook run after successfully archiving a subtree. +Hook functions are called with point on the subtree in the +original file. At this stage, the subtree has been added to the +archive location, but not yet deleted from the original file.") + (defun org-get-local-archive-location () "Get the archive location applicable at point." - (let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") + (let ((re "^[ \t]*#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") prop) (save-excursion (save-restriction @@ -158,7 +164,7 @@ archive file is." (save-restriction (goto-char (point-min)) (while (re-search-forward - "^\\(#\\+\\|[ \t]*:\\)ARCHIVE:[ \t]+\\(.*\\)" + "^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)" nil t) (setq file (org-extract-archive-file (org-match-string-no-properties 2))) @@ -198,9 +204,11 @@ The archive can be a certain top-level heading in the current file, or in a different file. The tree will be moved to that location, the subtree heading be marked DONE, and the current time will be added. -When called with prefix argument FIND-DONE, find whole trees without any +When called with a single prefix argument FIND-DONE, find whole trees without any open TODO items and archive them (after getting confirmation from the user). -If the cursor is not at a headline when this command is called, try all level +When called with a double prefix argument, find whole trees with timestamps before +today and archive them (after getting confirmation from the user). +If the cursor is not at a headline when these commands are called, try all level 1 trees. If the cursor is on a headline, only try the direct children of this heading." (interactive "P") @@ -213,8 +221,10 @@ this heading." (org-archive-subtree ,find-done)) org-loop-over-headlines-in-active-region cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) - (if find-done - (org-archive-all-done) + (cond + ((equal find-done '(4)) (org-archive-all-done)) + ((equal find-done '(16)) (org-archive-all-old)) + (t ;; Save all relevant TODO keyword-relatex variables (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler (tr-org-todo-keywords-1 org-todo-keywords-1) @@ -231,8 +241,7 @@ this heading." (error "No file associated to buffer")))) (olpath (mapconcat 'identity (org-get-outline-path) "/")) (time (format-time-string - (substring (cdr org-time-stamp-formats) 1 -1) - (current-time))) + (substring (cdr org-time-stamp-formats) 1 -1))) category todo priority ltags itags atags ;; end of variables that will be used for saving context location afile heading buffer level newfile-p infile-p visiting @@ -366,8 +375,10 @@ this heading." ;; Save and kill the buffer, if it is not the same buffer. (when (not (eq this-buffer buffer)) (save-buffer)))) - ;; Here we are back in the original buffer. Everything seems to have - ;; worked. So now cut the tree and finish up. + ;; Here we are back in the original buffer. Everything seems + ;; to have worked. So now run hooks, cut the tree and finish + ;; up. + (run-hooks 'org-archive-hook) (let (this-command) (org-cut-subtree)) (when (featurep 'org-inlinetask) (org-inlinetask-remove-END-maybe)) @@ -375,7 +386,7 @@ this heading." (message "Subtree archived %s" (if (eq this-buffer buffer) (concat "under heading: " heading) - (concat "in file: " (abbreviate-file-name afile)))))) + (concat "in file: " (abbreviate-file-name afile))))))) (org-reveal) (if (looking-at "^[ \t]*$") (outline-next-visible-heading 1)))) @@ -441,8 +452,7 @@ sibling does not exist, it will be created at the end of the subtree." (org-set-property "ARCHIVE_TIME" (format-time-string - (substring (cdr org-time-stamp-formats) 1 -1) - (current-time))) + (substring (cdr org-time-stamp-formats) 1 -1))) (outline-up-heading 1 t) (hide-subtree) (org-cycle-show-empty-lines 'folded) @@ -456,13 +466,50 @@ sibling does not exist, it will be created at the end of the subtree." If the cursor is not on a headline, try all level 1 trees. If it is on a headline, try all direct children. When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag." - (let ((re org-not-done-heading-regexp) re1 - (rea (concat ".*:" org-archive-tag ":")) + (org-archive-all-matches + (lambda (beg end) + (unless (re-search-forward org-not-done-heading-regexp end t) + "no open TODO items")) + tag)) + +(defun org-archive-all-old (&optional tag) + "Archive sublevels of the current tree with timestamps prior to today. +If the cursor is not on a headline, try all level 1 trees. If +it is on a headline, try all direct children. +When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag." + (org-archive-all-matches + (lambda (beg end) + (let (ts) + (and (re-search-forward org-ts-regexp end t) + (setq ts (match-string 0)) + (< (org-time-stamp-to-now ts) 0) + (if (not (looking-at + (concat "--\\(" org-ts-regexp "\\)"))) + (concat "old timestamp " ts) + (setq ts (concat "old timestamp " ts (match-string 0))) + (and (< (org-time-stamp-to-now (match-string 1)) 0) + ts))))) + tag)) + +(defun org-archive-all-matches (predicate &optional tag) + "Archive sublevels of the current tree that match PREDICATE. + +PREDICATE is a function of two arguments, BEG and END, which +specify the beginning and end of the headline being considered. +It is called with point positioned at BEG. The headline will be +archived if PREDICATE returns non-nil. If the return value of +PREDICATE is a string, it should describe the reason for +archiving the heading. + +If the cursor is not on a headline, try all level 1 trees. If it +is on a headline, try all direct children. When TAG is non-nil, +don't move trees, but mark them with the ARCHIVE tag." + (let ((rea (concat ".*:" org-archive-tag ":")) re1 (begm (make-marker)) (endm (make-marker)) - (question (if tag "Set ARCHIVE tag (no open TODO items)? " - "Move subtree to archive (no open TODO items)? ")) - beg end (cntarch 0)) + (question (if tag "Set ARCHIVE tag? " + "Move subtree to archive? ")) + reason beg end (cntarch 0)) (if (org-at-heading-p) (progn (setq re1 (concat "^" (regexp-quote @@ -482,11 +529,14 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag." (setq beg (match-beginning 0) end (save-excursion (org-end-of-subtree t) (point))) (goto-char beg) - (if (re-search-forward re end t) + (if (not (setq reason (funcall predicate beg end))) (goto-char end) (goto-char beg) (if (and (or (not tag) (not (looking-at rea))) - (y-or-n-p question)) + (y-or-n-p + (if (stringp reason) + (concat question "(" reason ")") + question))) (progn (if tag (org-toggle-tag org-archive-tag 'on) diff --git a/lisp/org-attach.el b/lisp/org-attach.el index bcf7ba7..7f61910 100644 --- a/lisp/org-attach.el +++ b/lisp/org-attach.el @@ -120,6 +120,17 @@ lns create a symbol link. Note that this is not supported (const :tag "Link to origin location" t) (const :tag "Link to the attach-dir location" attached))) +(defcustom org-attach-archive-delete nil + "Non-nil means attachments are deleted upon archiving a subtree. +When set to `query', ask the user instead." + :group 'org-attach + :version "25.1" + :package-version '(Org . "8.3") + :type '(choice + (const :tag "Never delete attachments" nil) + (const :tag "Always delete attachments" t) + (const :tag "Query the user" query))) + ;;;###autoload (defun org-attach () "The dispatcher for attachment commands. @@ -272,7 +283,8 @@ This checks for the existence of a \".git\" directory in that directory." (cd dir) (let ((have-annex (and org-attach-git-annex-cutoff - (file-exists-p (expand-file-name "annex" git-dir))))) + (or (file-exists-p (expand-file-name "annex" git-dir)) + (file-exists-p (expand-file-name ".git/annex" git-dir)))))) (dolist (new-or-modified (split-string (shell-command-to-string @@ -419,15 +431,15 @@ This can be used after files have been added externally." (and files (org-attach-tag)) (when org-attach-file-list-property (dolist (file files) - (unless (string-match "^\\." file) + (unless (string-match "^\\.\\.?\\'" file) (org-entry-add-to-multivalued-property (point) org-attach-file-list-property file)))))))) (defun org-attach-file-list (dir) "Return a list of files in the attachment directory. -This ignores files starting with a \".\", and files ending in \"~\"." +This ignores files ending in \"~\"." (delq nil - (mapcar (lambda (x) (if (string-match "^\\." x) nil x)) + (mapcar (lambda (x) (if (string-match "^\\.\\.?\\'" x) nil x)) (directory-files dir nil "[^~]\\'")))) (defun org-attach-reveal (&optional if-exists) @@ -475,6 +487,17 @@ Basically, this adds the path to the attachment directory, and a \"file:\" prefix." (concat "file:" (org-attach-expand file))) +(defun org-attach-archive-delete-maybe () + "Maybe delete subtree attachments when archiving. +This function is called by `org-archive-hook'. The option +`org-attach-archive-delete' controls its behavior." + (when (if (eq org-attach-archive-delete 'query) + (yes-or-no-p "Delete all attachments? ") + org-attach-archive-delete) + (org-attach-delete-all t))) + +(add-hook 'org-archive-hook 'org-attach-archive-delete-maybe) + (provide 'org-attach) ;; Local variables: diff --git a/lisp/org-bbdb.el b/lisp/org-bbdb.el index cfd5b3b..78f9b71 100644 --- a/lisp/org-bbdb.el +++ b/lisp/org-bbdb.el @@ -37,7 +37,7 @@ ;; the diary using bbdb-anniv.el. ;; ;; Put the following in /somewhere/at/home/diary.org and make sure -;; that this file is in `org-agenda-files` +;; that this file is in `org-agenda-files'. ;; ;; %%(org-bbdb-anniversaries) ;; diff --git a/lisp/org-bibtex.el b/lisp/org-bibtex.el index 75ac69b..7b2ed48 100644 --- a/lisp/org-bibtex.el +++ b/lisp/org-bibtex.el @@ -264,26 +264,39 @@ IDs must be unique." (defcustom org-bibtex-tags-are-keywords nil "Convert the value of the keywords field to tags and vice versa. -If set to t, comma-separated entries in a bibtex entry's keywords -field will be converted to org tags. Note: spaces will be escaped -with underscores, and characters that are not permitted in org + +When non-nil, comma-separated entries in a bibtex entry's keywords +field will be converted to Org tags. Note: spaces will be escaped +with underscores, and characters that are not permitted in Org tags will be removed. -If t, local tags in an org entry will be exported as a -comma-separated string of keywords when exported to bibtex. Tags -defined in `org-bibtex-tags' or `org-bibtex-no-export-tags' will -not be exported." +When non-nil, local tags in an Org entry will be exported as +a comma-separated string of keywords when exported to bibtex. +If `org-bibtex-inherit-tags' is non-nil, inherited tags will also +be exported as keywords. Tags defined in `org-bibtex-tags' or +`org-bibtex-no-export-tags' will not be exported." :group 'org-bibtex :version "24.1" :type 'boolean) (defcustom org-bibtex-no-export-tags nil "List of tag(s) that should not be converted to keywords. -This variable is relevant only if `org-bibtex-tags-are-keywords' is t." +This variable is relevant only if `org-bibtex-tags-are-keywords' +is non-nil." :group 'org-bibtex :version "24.1" :type '(repeat :tag "Tag" (string))) +(defcustom org-bibtex-inherit-tags nil + "Controls whether inherited tags are converted to bibtex keywords. +It is relevant only if `org-bibtex-tags-are-keywords' is non-nil. +Tag inheritence itself is controlled by `org-use-tag-inheritence' +and `org-exclude-tags-from-inheritence'." + :group 'org-bibtex + :version "25.1" + :package-version '(Org . "8.3") + :type 'boolean) + (defcustom org-bibtex-type-property-name "btype" "Property in which to store bibtex entry type (e.g., article)." :group 'org-bibtex @@ -332,7 +345,9 @@ This variable is relevant only if `org-bibtex-tags-are-keywords' is t." (append org-bibtex-tags org-bibtex-no-export-tags)) tag)) - (org-get-local-tags-at)))))) + (if org-bibtex-inherit-tags + (org-get-tags-at) + (org-get-local-tags-at))))))) (when type (let ((entry (format "@%s{%s,\n%s\n}\n" type id @@ -633,7 +648,7 @@ This uses `bibtex-parse-entry'." (defun org-bibtex-read-buffer (buffer) "Read all bibtex entries in BUFFER and save to `org-bibtex-entries'. Return the number of saved entries." - (interactive "bbuffer: ") + (interactive "bBuffer: ") (let ((start-length (length org-bibtex-entries))) (with-current-buffer buffer (save-excursion @@ -643,12 +658,12 @@ Return the number of saved entries." (org-bibtex-read) (bibtex-beginning-of-entry)))) (let ((added (- (length org-bibtex-entries) start-length))) - (message "parsed %d entries" added) + (message "Parsed %d entries" added) added))) (defun org-bibtex-read-file (file) "Read FILE with `org-bibtex-read-buffer'." - (interactive "ffile: ") + (interactive "fFile: ") (org-bibtex-read-buffer (find-file-noselect file 'nowarn 'rawfile))) (defun org-bibtex-write () @@ -694,7 +709,7 @@ Return the number of saved entries." (defun org-bibtex-import-from-file (file) "Read bibtex entries from FILE and insert as Org-mode headlines after point." - (interactive "ffile: ") + (interactive "fFile: ") (dotimes (_ (org-bibtex-read-file file)) (save-excursion (org-bibtex-write)) (re-search-forward org-property-end-re) diff --git a/lisp/org-capture.el b/lisp/org-capture.el index c708683..bfdb475 100644 --- a/lisp/org-capture.el +++ b/lisp/org-capture.el @@ -1,6 +1,6 @@ ;;; org-capture.el --- Fast note taking in Org-mode -;; Copyright (C) 2010-2014 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: outlines, hypermedia, calendar, wp @@ -53,7 +53,7 @@ (declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction)) -(declare-function org-table-get-specials "org-table" ()) +(declare-function org-table-analyze "org-table" ()) (declare-function org-table-goto-line "org-table" (N)) (declare-function org-pop-to-buffer-same-window "org-compat" (&optional buffer-or-name norecord label)) @@ -64,6 +64,7 @@ (defvar org-remember-default-headline) (defvar org-remember-templates) (defvar org-table-hlines) +(defvar org-table-current-begin-pos) (defvar dired-buffers) (defvar org-capture-clock-was-started nil @@ -201,7 +202,7 @@ properties are: :clock-resume Start the interrupted clock when finishing the capture. Note that :clock-keep has precedence over :clock-resume. - When setting both to `t', the current clock will run and + When setting both to t, the current clock will run and the previous one will not be resumed. :unnarrowed Do not narrow the target buffer, simply show the @@ -812,7 +813,8 @@ already gone. Any prefix argument will be passed to the refile command." "Go to the location where the last capture note was stored." (interactive) (org-goto-marker-or-bmk org-capture-last-stored-marker - "org-capture-last-stored") + (plist-get org-bookmark-names-plist + :last-capture)) (message "This is the last note stored by a capture process")) ;;; Supporting functions for handling the process @@ -822,7 +824,7 @@ already gone. Any prefix argument will be passed to the refile command." (org-capture-put :initial-target-region ;; Check if the buffer is currently narrowed - (when (/= (buffer-size) (- (point-max) (point-min))) + (when (org-buffer-narrowed-p) (cons (point-min) (point-max)))) ;; store the current point (org-capture-put :initial-target-position (point))) @@ -965,12 +967,15 @@ Store them in the capture property list." (defun org-capture-expand-file (file) "Expand functions and symbols for FILE. When FILE is a function, call it. When it is a form, evaluate -it. When it is a variable, retrieve the value. Return whatever we get." +it. When it is a variable, retrieve the value. When it is +a string, return it. However, if it is the empty string, return +`org-default-notes-file' instead." (cond + ((equal file "") org-default-notes-file) ((org-string-nw-p file) file) ((functionp file) (funcall file)) ((and (symbolp file) (boundp file)) (symbol-value file)) - ((and file (consp file)) (eval file)) + ((consp file) (eval file)) (t file))) (defun org-capture-target-buffer (file) @@ -1022,9 +1027,9 @@ may have been stored before." (target-entry-p (org-capture-get :target-entry-p)) level beg end file) + (and (org-capture-get :exact-position) + (goto-char (org-capture-get :exact-position))) (cond - ((org-capture-get :exact-position) - (goto-char (org-capture-get :exact-position))) ((not target-entry-p) ;; Insert as top-level entry, either at beginning or at end of file (setq level 1) @@ -1074,21 +1079,18 @@ may have been stored before." (t (setq beg (1+ (point-at-eol)) end (save-excursion (outline-next-heading) (point))))) + (setq ind nil) (if (org-capture-get :prepend) (progn (goto-char beg) - (if (org-list-search-forward (org-item-beginning-re) end t) - (progn - (goto-char (match-beginning 0)) - (setq ind (org-get-indentation))) - (goto-char end) - (setq ind 0))) + (when (org-list-search-forward (org-item-beginning-re) end t) + (goto-char (match-beginning 0)) + (setq ind (org-get-indentation)))) (goto-char end) - (if (org-list-search-backward (org-item-beginning-re) beg t) - (progn - (setq ind (org-get-indentation)) - (org-end-of-item)) - (setq ind 0)))) + (when (org-list-search-backward (org-item-beginning-re) beg t) + (setq ind (org-get-indentation)) + (org-end-of-item))) + (unless ind (goto-char end))) ;; Remove common indentation (setq txt (org-remove-indentation txt)) ;; Make sure this is indeed an item @@ -1096,17 +1098,22 @@ may have been stored before." (setq txt (concat "- " (mapconcat 'identity (split-string txt "\n") "\n ")))) + ;; Prepare surrounding empty lines. + (org-capture-empty-lines-before) + (setq beg (point)) + (unless (eolp) (save-excursion (insert "\n"))) + (unless ind + (org-indent-line) + (setq ind (org-get-indentation)) + (delete-region beg (point))) ;; Set the correct indentation, depending on context (setq ind (make-string ind ?\ )) (setq txt (concat ind (mapconcat 'identity (split-string txt "\n") (concat "\n" ind)) "\n")) - ;; Insert, with surrounding empty lines - (org-capture-empty-lines-before) - (setq beg (point)) + ;; Insert item. (insert txt) - (or (bolp) (insert "\n")) (org-capture-empty-lines-after 1) (org-capture-position-for-last-stored beg) (forward-char 1) @@ -1148,21 +1155,23 @@ may have been stored before." ;; Check if the template is good (if (not (string-match org-table-dataline-regexp txt)) (setq txt "| %?Bad template |\n")) + (if (functionp table-line-pos) + (setq table-line-pos (funcall table-line-pos)) + (setq table-line-pos (eval table-line-pos))) (cond ((and table-line-pos (string-match "\\(I+\\)\\([-+][0-9]\\)" table-line-pos)) ;; we have a complex line specification - (goto-char (point-min)) - (let ((nh (- (match-end 1) (match-beginning 1))) - (delta (string-to-number (match-string 2 table-line-pos))) - ll) + (let ((ll (ignore-errors + (save-match-data (org-table-analyze)) + (aref org-table-hlines + (- (match-end 1) (match-beginning 1))))) + (delta (string-to-number (match-string 2 table-line-pos)))) ;; The user wants a special position in the table - (org-table-get-specials) - (setq ll (ignore-errors (aref org-table-hlines nh))) - (unless ll (error "Invalid table line specification \"%s\"" - table-line-pos)) - (setq ll (+ ll delta (if (< delta 0) 0 -1))) - (org-goto-line ll) + (unless ll + (error "Invalid table line specification \"%s\"" table-line-pos)) + (goto-char org-table-current-begin-pos) + (forward-line (+ ll delta (if (< delta 0) 0 -1))) (org-table-insert-row 'below) (beginning-of-line 1) (delete-region (point) (1+ (point-at-eol))) @@ -1215,7 +1224,7 @@ Of course, if exact position has been required, just put it there." ;; we should place the text into this entry (if (org-capture-get :prepend) ;; Skip meta data and drawers - (org-end-of-meta-data-and-drawers) + (org-end-of-meta-data t) ;; go to ent of the entry text, before the next headline (outline-next-heading))) (t @@ -1581,8 +1590,7 @@ The template may still contain \"%?\" for cursor positioning." (unless template (setq template "") (message "No template") (ding) (sit-for 1)) (save-window-excursion - (delete-other-windows) - (org-pop-to-buffer-same-window (get-buffer-create "*Capture*")) + (org-switch-to-buffer-other-window (get-buffer-create "*Capture*")) (erase-buffer) (insert template) (goto-char (point-min)) @@ -1602,8 +1610,6 @@ The template may still contain \"%?\" for cursor positioning." (insert-file-contents filename) (error (insert (format "%%![Couldn't insert %s: %s]" filename error))))))) - ;; %() embedded elisp - (org-capture-expand-embedded-elisp) ;; The current time (goto-char (point-min)) @@ -1633,6 +1639,10 @@ The template may still contain \"%?\" for cursor positioning." (intern (match-string 1))) "")) (replace-match x t t))))) + ;; %() embedded elisp + (goto-char (point-min)) + (org-capture-expand-embedded-elisp) + ;; Turn on org-mode in temp buffer, set local variables ;; This is to support completion in interactive prompts (let ((org-inhibit-startup t)) (org-mode)) diff --git a/lisp/org-clock.el b/lisp/org-clock.el index 892ae18..6e34483 100644 --- a/lisp/org-clock.el +++ b/lisp/org-clock.el @@ -32,10 +32,12 @@ (require 'cl)) (require 'org) -(declare-function calendar-absolute-from-iso "cal-iso" (&optional date)) +(declare-function calendar-iso-to-absolute "cal-iso" (&optional date)) (declare-function notifications-notify "notifications" (&rest params)) (declare-function org-pop-to-buffer-same-window "org-compat" (&optional buffer-or-name norecord label)) -(declare-function org-refresh-properties "org" (dprop tprop)) +(declare-function org-element-property "org-element" (property element)) +(declare-function org-element-type "org-element" (element)) +(declare-function org-table-goto-line "org-table" (n)) (defvar org-time-stamp-formats) (defvar org-ts-what) (defvar org-frame-title-format-backup frame-title-format) @@ -45,19 +47,26 @@ :tag "Org Clock" :group 'org-progress) -(defcustom org-clock-into-drawer org-log-into-drawer - "Should clocking info be wrapped into a drawer? -When t, clocking info will always be inserted into a :LOGBOOK: drawer. -If necessary, the drawer will be created. -When nil, the drawer will not be created, but used when present. -When an integer and the number of clocking entries in an item -reaches or exceeds this number, a drawer will be created. -When a string, it names the drawer to be used. - -The default for this variable is the value of `org-log-into-drawer', -which see." +(defcustom org-clock-into-drawer t + "Non-nil when clocking info should be wrapped into a drawer. + +When non-nil, clocking info will be inserted into the same drawer +as log notes (see variable `org-log-into-drawer'), if it exists, +or \"LOGBOOK\" otherwise. If necessary, the drawer will be +created. + +When an integer, the drawer is created only when the number of +clocking entries in an item reaches or exceeds this value. + +When a string, it becomes the name of the drawer, ignoring the +log notes drawer altogether. + +Do not check directly this variable in a Lisp program. Call +function `org-clock-into-drawer' instead." :group 'org-todo :group 'org-clock + :version "25.1" + :package-version '(Org . "8.3") :type '(choice (const :tag "Always" t) (const :tag "Only when drawer exists" nil) @@ -66,20 +75,22 @@ which see." (string :tag "Into Drawer named..."))) (defun org-clock-into-drawer () - "Return the value of `org-clock-into-drawer', but let properties overrule. + "Value of `org-clock-into-drawer'. but let properties overrule. + If the current entry has or inherits a CLOCK_INTO_DRAWER -property, it will be used instead of the default value; otherwise -if the current entry has or inherits a LOG_INTO_DRAWER property, -it will be used instead of the default value. -The default is the value of the customizable variable `org-clock-into-drawer', -which see." - (let ((p (org-entry-get nil "CLOCK_INTO_DRAWER" 'inherit)) - (q (org-entry-get nil "LOG_INTO_DRAWER" 'inherit))) - (cond - ((or (not (or p q)) (equal p "nil") (equal q "nil")) org-clock-into-drawer) - ((or (equal p "t") (equal q "t")) "LOGBOOK") - ((not p) q) - (t p)))) +property, it will be used instead of the default value. + +Return value is either a string, an integer, or nil." + (let ((p (org-entry-get nil "CLOCK_INTO_DRAWER" 'inherit t))) + (cond ((equal p "nil") nil) + ((equal p "t") (or (org-log-into-drawer) "LOGBOOK")) + ((org-string-nw-p p) + (if (org-string-match-p "\\`[0-9]+\\'" p) (string-to-number p) p)) + ((org-string-nw-p org-clock-into-drawer)) + ((integerp org-clock-into-drawer) org-clock-into-drawer) + ((not org-clock-into-drawer) nil) + ((org-log-into-drawer)) + (t "LOGBOOK")))) (defcustom org-clock-out-when-done t "When non-nil, clock will be stopped when the clocked entry is marked DONE. @@ -413,6 +424,26 @@ if you are using Debian." :package-version '(Org . "8.0") :type 'string) +(defcustom org-clock-goto-before-context 2 + "Number of lines of context to display before currently clocked-in entry. +This applies when using `org-clock-goto'." + :group 'org-clock + :type 'integer) + +(defcustom org-clock-display-default-range 'thisyear + "Default range when displaying clocks with `org-clock-display'." + :group 'org-clock + :type '(choice (const today) + (const yesterday) + (const thisweek) + (const lastweek) + (const thismonth) + (const lastmonth) + (const thisyear) + (const lastyear) + (const untilnow) + (const :tag "Select range interactively" interactive))) + (defvar org-clock-in-prepare-hook nil "Hook run when preparing the clock. This hook is run before anything happens to the task that @@ -430,6 +461,28 @@ to add an effort property.") (defvar org-clock-has-been-used nil "Has the clock been used during the current Emacs session?") +(defconst org-clock--oldest-date + (let* ((dichotomy + (lambda (min max pred) + (if (funcall pred min) min + (incf min) + (while (> (- max min) 1) + (let ((mean (+ (ash min -1) (ash max -1) (logand min max 1)))) + (if (funcall pred mean) (setq max mean) (setq min mean))))) + max)) + (high + (funcall dichotomy + most-negative-fixnum + 0 + (lambda (m) (ignore-errors (decode-time (list m 0)))))) + (low + (funcall dichotomy + most-negative-fixnum + 0 + (lambda (m) (ignore-errors (decode-time (list high m))))))) + (list high low)) + "Internal time for oldest date representable on the system.") + ;;; The clock for measuring work time. (defvar org-mode-line-string "") @@ -559,6 +612,7 @@ of a different task.") (fit-window-to-buffer nil nil (if (< chl 10) chl (+ 5 chl))) (message (or prompt "Select task for clocking:")) (setq cursor-type nil rpl (read-char-exclusive)) + (kill-buffer) (cond ((eq rpl ?q) nil) ((eq rpl ?x) nil) @@ -775,11 +829,12 @@ If CLOCK-SOUND is non-nil, it overrides `org-clock-sound'." "Search through the given file and find all open clocks." (let ((buf (or (get-file-buffer file) (find-file-noselect file))) + (org-clock-re (concat org-clock-string " \\(\\[.*?\\]\\)$")) clocks) (with-current-buffer buf (save-excursion (goto-char (point-min)) - (while (re-search-forward "CLOCK: \\(\\[.*?\\]\\)$" nil t) + (while (re-search-forward org-clock-re nil t) (push (cons (copy-marker (match-end 1) t) (org-time-string-to-time (match-string 1))) clocks)))) clocks)) @@ -884,7 +939,7 @@ If necessary, clock-out of the currently active clock." (defun org-clock-jump-to-current-clock (&optional effective-clock) (interactive) - (let ((org-clock-into-drawer (org-clock-into-drawer)) + (let ((drawer (org-clock-into-drawer)) (clock (or effective-clock (cons org-clock-marker org-clock-start-time)))) (unless (marker-buffer (car clock)) @@ -892,23 +947,18 @@ If necessary, clock-out of the currently active clock." (org-with-clock clock (org-clock-goto)) (with-current-buffer (marker-buffer (car clock)) (goto-char (car clock)) - (if org-clock-into-drawer - (let ((logbook - (if (stringp org-clock-into-drawer) - (concat ":" org-clock-into-drawer ":") - ":LOGBOOK:"))) - (ignore-errors - (outline-flag-region - (save-excursion - (outline-back-to-heading t) - (search-forward logbook) - (goto-char (match-beginning 0))) - (save-excursion - (outline-back-to-heading t) - (search-forward logbook) - (search-forward ":END:") - (goto-char (match-end 0))) - nil))))))) + (when drawer + (org-with-wide-buffer + (let ((drawer-re (format "^[ \t]*:%s:[ \t]*$" + (regexp-quote (or drawer "LOGBOOK")))) + (beg (save-excursion (outline-back-to-heading t) (point)))) + (catch 'exit + (while (re-search-backward drawer-re beg t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'drawer) + (when (> (org-element-property :end element) (car clock)) + (org-flag-drawer nil element)) + (throw 'exit nil))))))))))) (defun org-clock-resolve (clock &optional prompt-fn last-valid fail-quietly) "Resolve an open org-mode clock. @@ -1046,9 +1096,9 @@ If `only-dangling-p' is non-nil, only ask to resolve dangling (lambda (clock) (format "Dangling clock started %d mins ago" - (floor - (/ (- (org-float-time (current-time)) - (org-float-time (cdr clock))) 60)))))) + (floor (- (org-float-time) + (org-float-time (cdr clock))) + 60))))) (or last-valid (cdr clock))))))))))) @@ -1066,9 +1116,11 @@ If `only-dangling-p' is non-nil, only ask to resolve dangling (defvar org-x11idle-exists-p ;; Check that x11idle exists (and (eq window-system 'x) - (eq (call-process-shell-command "command" nil nil nil "-v" org-clock-x11idle-program-name) 0) + (eq 0 (call-process-shell-command + (format "command -v %s" org-clock-x11idle-program-name))) ;; Check that x11idle can retrieve the idle time - (eq (call-process-shell-command org-clock-x11idle-program-name nil nil nil) 0))) + ;; FIXME: Why "..-shell-command" rather than just `call-process'? + (eq 0 (call-process-shell-command org-clock-x11idle-program-name)))) (defun org-x11-idle-seconds () "Return the current X11 idle time in seconds." @@ -1130,7 +1182,9 @@ time as the start time \(see `org-clock-continuously' to make this the default behavior.)" (interactive "P") (setq org-clock-notification-was-shown nil) - (org-refresh-properties org-effort-property 'org-effort) + (org-refresh-properties + org-effort-property '((effort . identity) + (effort-minutes . org-duration-string-to-minutes))) (catch 'abort (let ((interrupting (and (not org-clock-resolving-clocks-due-to-idleness) (org-clocking-p))) @@ -1321,8 +1375,7 @@ With three universal prefix arguments, interactively prompt for a todo state to switch to, overriding the existing value `org-clock-in-switch-to-state'." (interactive "P") - (if (equal arg '(4)) - (org-clock-in (org-clock-select-task)) + (if (equal arg '(4)) (org-clock-in arg) (let ((start-time (if (or org-clock-continuously (equal arg '(16))) (or org-clock-out-time (org-current-time org-clock-rounding-minutes t)) @@ -1368,10 +1421,12 @@ decides which time to use." (current-time)) ((equal cmt "today") (setq org--msg-extra "showing today's task time.") - (let* ((dt (decode-time (current-time)))) - (setq dt (append (list 0 0 0) (nthcdr 3 dt))) - (if org-extend-today-until - (setf (nth 2 dt) org-extend-today-until)) + (let* ((dt (decode-time)) + (hour (nth 2 dt)) + (day (nth 3 dt))) + (if (< hour org-extend-today-until) (setf (nth 3 dt) (1- day))) + (setf (nth 2 dt) org-extend-today-until) + (setq dt (append (list 0 0) (nthcdr 2 dt))) (apply 'encode-time dt))) ((or (equal cmt "all") (and (or (not cmt) (equal cmt "auto")) @@ -1393,87 +1448,100 @@ When FIND-UNCLOSED is non-nil, first check if there is an unclosed clock line and position cursor in that line." (org-back-to-heading t) (catch 'exit - (let* ((org-clock-into-drawer (org-clock-into-drawer)) - (beg (save-excursion - (beginning-of-line 2) - (or (bolp) (newline)) - (point))) - (end (progn (outline-next-heading) (point))) - (re (concat "^[ \t]*" org-clock-string)) - (cnt 0) - (drawer (if (stringp org-clock-into-drawer) - org-clock-into-drawer "LOGBOOK")) - first last ind-last) - (goto-char beg) - (when (and find-unclosed - (re-search-forward - (concat "^[ \t]*" org-clock-string - " \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}" - " *\\sw+ +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$") - end t)) - (beginning-of-line 1) - (throw 'exit t)) - (when (eobp) (newline) (setq end (max (point) end))) - (when (re-search-forward (concat "^[ \t]*:" drawer ":") end t) - ;; we seem to have a CLOCK drawer, so go there. - (beginning-of-line 2) - (or org-log-states-order-reversed - (and (re-search-forward org-property-end-re nil t) - (goto-char (match-beginning 0)))) - (throw 'exit t)) - ;; Lets count the CLOCK lines + (let* ((beg (line-beginning-position 2)) + (end (save-excursion (outline-next-heading) (point))) + (org-clock-into-drawer (org-clock-into-drawer)) + (drawer (cond + ((not org-clock-into-drawer) nil) + ((stringp org-clock-into-drawer) org-clock-into-drawer) + (t "LOGBOOK")))) + ;; Look for a running clock if FIND-UNCLOSED in non-nil. + (when find-unclosed + (let ((open-clock-re + (concat "^[ \t]*" + org-clock-string + " \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}" + " *\\sw+ +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$"))) + (while (re-search-forward open-clock-re end t) + (let ((element (org-element-at-point))) + (when (and (eq (org-element-type element) 'clock) + (eq (org-element-property :status element) 'running)) + (beginning-of-line) + (throw 'exit t)))))) + ;; Look for an existing clock drawer. + (when drawer + (goto-char beg) + (let ((drawer-re (concat "^[ \t]*:" (regexp-quote drawer) ":[ \t]*$"))) + (while (re-search-forward drawer-re end t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'drawer) + (let ((cend (org-element-property :contents-end element))) + (if (and (not org-log-states-order-reversed) cend) + (goto-char cend) + (forward-line)) + (throw 'exit t))))))) (goto-char beg) - (while (re-search-forward re end t) - (setq first (or first (match-beginning 0)) - last (match-beginning 0) - cnt (1+ cnt))) - (when (and (integerp org-clock-into-drawer) - last - (>= (1+ cnt) org-clock-into-drawer)) - ;; Wrap current entries into a new drawer - (goto-char last) - (setq ind-last (org-get-indentation)) - (beginning-of-line 2) - (if (and (>= (org-get-indentation) ind-last) - (org-at-item-p)) - (when (and (>= (org-get-indentation) ind-last) - (org-at-item-p)) - (let ((struct (org-list-struct))) - (goto-char (org-list-get-bottom-point struct))))) - (insert ":END:\n") - (beginning-of-line 0) - (org-indent-line-to ind-last) - (goto-char first) - (insert ":" drawer ":\n") - (beginning-of-line 0) - (org-indent-line) - (org-flag-drawer t) - (beginning-of-line 2) - (or org-log-states-order-reversed - (and (re-search-forward org-property-end-re nil t) - (goto-char (match-beginning 0)))) - (throw 'exit nil)) - - (goto-char beg) - (while (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) - (not (equal (match-string 1) org-clock-string))) - ;; Planning info, skip to after it - (beginning-of-line 2) - (or (bolp) (newline))) - (when (or (eq org-clock-into-drawer t) - (stringp org-clock-into-drawer) - (and (integerp org-clock-into-drawer) - (< org-clock-into-drawer 2))) - (insert ":" drawer ":\n:END:\n") - (beginning-of-line -1) - (org-indent-line) - (org-flag-drawer t) - (beginning-of-line 2) - (org-indent-line) - (beginning-of-line) - (or org-log-states-order-reversed - (and (re-search-forward org-property-end-re nil t) - (goto-char (match-beginning 0)))))))) + (let ((clock-re (concat "^[ \t]*" org-clock-string)) + (count 0) positions first) + ;; Count the CLOCK lines and store their positions. + (save-excursion + (while (re-search-forward clock-re end t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'clock) + (setq positions (cons (line-beginning-position) positions) + count (1+ count)))))) + (cond + ((null positions) + ;; Skip planning line and property drawer, if any. + (when (org-looking-at-p org-planning-line-re) (forward-line)) + (when (looking-at org-property-drawer-re) + (goto-char (match-end 0)) + (forward-line)) + (unless (bolp) (insert "\n")) + ;; Create a new drawer if necessary. + (when (and org-clock-into-drawer + (or (not (wholenump org-clock-into-drawer)) + (< org-clock-into-drawer 2))) + (let ((beg (point))) + (insert ":" drawer ":\n:END:\n") + (org-indent-region beg (point)) + (goto-char beg) + (org-flag-drawer t) + (forward-line)))) + ;; When a clock drawer needs to be created because of the + ;; number of clock items, collect all clocks in the section + ;; and wrap them within the drawer. + ((and (wholenump org-clock-into-drawer) + (>= (1+ count) org-clock-into-drawer)) + ;; Skip planning line and property drawer, if any. + (when (org-looking-at-p org-planning-line-re) (forward-line)) + (when (looking-at org-property-drawer-re) + (goto-char (match-end 0)) + (forward-line)) + (let ((beg (point))) + (insert + (mapconcat + (lambda (p) + (save-excursion + (goto-char p) + (org-trim (delete-and-extract-region + (save-excursion (skip-chars-backward " \r\t\n") + (line-beginning-position 2)) + (line-beginning-position 2))))) + positions "\n") + "\n:END:\n") + (let ((end (point-marker))) + (goto-char beg) + (save-excursion (insert ":" drawer ":\n")) + (org-flag-drawer t) + (org-indent-region (point) end) + (forward-line) + (unless org-log-states-order-reversed + (goto-char end) + (beginning-of-line -1)) + (set-marker end nil)))) + (org-log-states-order-reversed (goto-char (car (last positions)))) + (t (goto-char (car positions)))))))) ;;;###autoload (defun org-clock-out (&optional switch-to-state fail-quietly at-time) @@ -1561,11 +1629,14 @@ to, overriding the existing value of `org-clock-out-switch-to-state'." (message (concat "Clock stopped at %s after " (org-minutes-to-clocksum-string (+ (* 60 h) m)) "%s") te (if remove " => LINE REMOVED" "")) - (let ((h org-clock-out-hook)) + (let ((h org-clock-out-hook) + (clock-drawer (org-clock-into-drawer))) ;; If a closing note needs to be stored in the drawer ;; where clocks are stored, let's temporarily disable - ;; `org-clock-remove-empty-clock-drawer' - (if (and (equal org-clock-into-drawer org-log-into-drawer) + ;; `org-clock-remove-empty-clock-drawer'. + (if (and clock-drawer + (not (stringp clock-drawer)) + (org-log-into-drawer) (eq org-log-done 'note) org-clock-out-when-done) (setq h (delq 'org-clock-remove-empty-clock-drawer h))) @@ -1577,17 +1648,15 @@ to, overriding the existing value of `org-clock-out-switch-to-state'." (defun org-clock-remove-empty-clock-drawer nil "Remove empty clock drawer in the current subtree." - (let* ((olid (or (org-entry-get (point) "LOG_INTO_DRAWER") - org-log-into-drawer)) - (clock-drawer (if (eq t olid) "LOGBOOK" olid)) - (end (save-excursion (org-end-of-subtree t t)))) + (let ((clock-drawer (org-log-into-drawer)) + (end (save-excursion (org-end-of-subtree t t)))) (when clock-drawer (save-excursion (org-back-to-heading t) (while (and (< (point) end) (search-forward clock-drawer end t)) (goto-char (match-beginning 0)) - (org-remove-empty-drawer-at clock-drawer (point)) + (org-remove-empty-drawer-at (point)) (forward-line 1)))))) (defun org-clock-timestamps-up (&optional n) @@ -1651,12 +1720,13 @@ Optional argument N tells to change by that many units." (setq frame-title-format org-frame-title-format-backup) (force-mode-line-update) (error "No active clock")) - (save-excursion ; Do not replace this with `with-current-buffer'. + (save-excursion ; Do not replace this with `with-current-buffer'. (org-no-warnings (set-buffer (org-clocking-buffer))) (goto-char org-clock-marker) - (if (org-looking-back (concat "^[ \t]*" org-clock-string ".*")) + (if (org-looking-back (concat "^[ \t]*" org-clock-string ".*") + (line-beginning-position)) (progn (delete-region (1- (point-at-bol)) (point-at-eol)) - (org-remove-empty-drawer-at "LOGBOOK" (point))) + (org-remove-empty-drawer-at (point))) (message "Clock gone, cancel the timer anyway") (sit-for 2))) (move-marker org-clock-marker nil) @@ -1668,12 +1738,6 @@ Optional argument N tells to change by that many units." (message "Clock canceled") (run-hooks 'org-clock-cancel-hook)) -(defcustom org-clock-goto-before-context 2 - "Number of lines of context to display before currently clocked-in entry. -This applies when using `org-clock-goto'." - :group 'org-clock - :type 'integer) - ;;;###autoload (defun org-clock-goto (&optional select) "Go to the currently clocked-in entry, or to the most recently clocked one. @@ -1709,9 +1773,22 @@ With prefix arg SELECT, offer recently clocked tasks for selection." (defun org-clock-sum-today (&optional headline-filter) "Sum the times for each subtree for today." - (interactive) (let ((range (org-clock-special-range 'today))) - (org-clock-sum (car range) (cadr range) nil :org-clock-minutes-today))) + (org-clock-sum (car range) (cadr range) + headline-filter :org-clock-minutes-today))) + +(defun org-clock-sum-custom (&optional headline-filter range propname) + "Sum the times for each subtree for today." + (let ((r (or (and (symbolp range) (org-clock-special-range range)) + (org-clock-special-range + (intern (completing-read + "Range: " + '("today" "yesterday" "thisweek" "lastweek" + "thismonth" "lastmonth" "thisyear" "lastyear" + "interactive") + nil t)))))) + (org-clock-sum (car r) (cadr r) + headline-filter (or propname :org-clock-minutes-custom)))) ;;;###autoload (defun org-clock-sum (&optional tstart tend headline-filter propname) @@ -1722,7 +1799,6 @@ HEADLINE-FILTER is a zero-arg function that, if specified, is called for each headline in the time range with point at the headline. Headlines for which HEADLINE-FILTER returns nil are excluded from the clock summation. PROPNAME lets you set a custom text property instead of :org-clock-minutes." - (interactive) (org-with-silent-modifications (let* ((re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*" org-clock-string @@ -1780,6 +1856,8 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes." (save-excursion (save-match-data (funcall headline-filter)))))) (setq level (- (match-end 1) (match-beginning 1))) + (when (>= level lmax) + (setq ltimes (vconcat ltimes (make-vector lmax 0)) lmax (* 2 lmax))) (when (or (> t1 0) (> (aref ltimes level) 0)) (when (or headline-included headline-forced) (if headline-included @@ -1812,59 +1890,79 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes." org-clock-file-total-minutes))) ;;;###autoload -(defun org-clock-display (&optional total-only) +(defun org-clock-display (&optional arg) "Show subtree times in the entire buffer. -If TOTAL-ONLY is non-nil, only show the total time for the entire file -in the echo area. + +With one universal prefix argument, show the total time for +today. With two universal prefix arguments, show the total time +for a custom range, entered at the prompt. With three universal +prefix arguments, show the total time in the echo area. Use \\[org-clock-remove-overlays] to remove the subtree times." - (interactive) + (interactive "P") (org-clock-remove-overlays) - (let (time h m p) - (org-clock-sum) - (unless total-only + (let* ((todayp (equal arg '(4))) + (customp (member arg '((16) today yesterday + thisweek lastweek thismonth + lastmonth thisyear lastyear + untilnow interactive))) + (prop (cond ((not arg) :org-clock-minutes-default) + (todayp :org-clock-minutes-today) + (customp :org-clock-minutes-custom) + (t :org-clock-minutes))) + time h m p) + (cond ((not arg) (org-clock-sum-custom + nil org-clock-display-default-range prop)) + (todayp (org-clock-sum-today)) + (customp (org-clock-sum-custom nil arg)) + (t (org-clock-sum))) + (unless (eq arg '(64)) (save-excursion (goto-char (point-min)) (while (or (and (equal (setq p (point)) (point-min)) - (get-text-property p :org-clock-minutes)) + (get-text-property p prop)) (setq p (next-single-property-change - (point) :org-clock-minutes))) + (point) prop))) (goto-char p) - (when (setq time (get-text-property p :org-clock-minutes)) - (org-clock-put-overlay time (funcall outline-level)))) + (when (setq time (get-text-property p prop)) + (org-clock-put-overlay time))) (setq h (/ org-clock-file-total-minutes 60) m (- org-clock-file-total-minutes (* 60 h))) ;; Arrange to remove the overlays upon next change. (when org-remove-highlights-with-change (org-add-hook 'before-change-functions 'org-clock-remove-overlays nil 'local)))) - (message (concat "Total file time: " - (org-minutes-to-clocksum-string org-clock-file-total-minutes) - " (%d hours and %d minutes)") h m))) + (message (concat (format "Total file time%s: " + (cond (todayp " for today") + (customp " (custom)") + (t ""))) + (org-minutes-to-clocksum-string + org-clock-file-total-minutes) + " (%d hours and %d minutes)") + h m))) (defvar org-clock-overlays nil) (make-variable-buffer-local 'org-clock-overlays) -(defun org-clock-put-overlay (time &optional level) +(defun org-clock-put-overlay (time) "Put an overlays on the current line, displaying TIME. -If LEVEL is given, prefix time with a corresponding number of stars. This creates a new overlay and stores it in `org-clock-overlays', so that it will be easy to remove." - (let* ((l (if level (org-get-valid-level level 0) 0)) - ov tx) + (let (ov tx) (beginning-of-line) (when (looking-at org-complex-heading-regexp) (goto-char (match-beginning 4))) (setq ov (make-overlay (point) (point-at-eol)) tx (concat (buffer-substring-no-properties (point) (match-end 4)) - (make-string - (max 0 (- (- 60 (current-column)) - (- (match-end 4) (match-beginning 4)) - (length (org-get-at-bol 'line-prefix)))) ?.) - (org-add-props (concat (make-string l ?*) " " - (org-minutes-to-clocksum-string time) - (make-string (- 16 l) ?\ )) - (list 'face 'org-clock-overlay)) + (org-add-props + (make-string + (max 0 (- (- 60 (current-column)) + (- (match-end 4) (match-beginning 4)) + (length (org-get-at-bol 'line-prefix)))) ?·) + '(face shadow)) + (org-add-props + (format " %9s " (org-minutes-to-clocksum-string time)) + '(face org-clock-overlay)) "")) (if (not (featurep 'xemacs)) (overlay-put ov 'display tx) @@ -1927,7 +2025,7 @@ fontified, and then returned." (org-mode) (org-create-dblock props) (org-update-dblock) - (font-lock-fontify-buffer) + (font-lock-ensure) (forward-line 2) (buffer-substring (point) (progn (re-search-forward "^[ \t]*#\\+END" nil t) @@ -2016,127 +2114,159 @@ buffer and update it." (defun org-clock-special-range (key &optional time as-strings wstart mstart) "Return two times bordering a special time range. -Key is a symbol specifying the range and can be one of `today', `yesterday', -`thisweek', `lastweek', `thismonth', `lastmonth', `thisyear', `lastyear'. -By default, a week starts Monday 0:00 and ends Sunday 24:00. -The range is determined relative to TIME, which defaults to current time. -The return value is a cons cell with two internal times like the ones -returned by `current time' or `encode-time'. -If AS-STRINGS is non-nil, the returned times will be formatted strings. -If WSTART is non-nil, use this number to specify the starting day of a -week (monday is 1). -If MSTART is non-nil, use this number to specify the starting day of a -month (1 is the first day of the month). -If you can combine both, the month starting day will have priority." - (if (integerp key) (setq key (intern (number-to-string key)))) - (let* ((tm (decode-time (or time (current-time)))) - (s 0) (m (nth 1 tm)) (h (nth 2 tm)) - (d (nth 3 tm)) (month (nth 4 tm)) (y (nth 5 tm)) + +KEY is a symbol specifying the range and can be one of `today', +`yesterday', `thisweek', `lastweek', `thismonth', `lastmonth', +`thisyear', `lastyear' or `untilnow'. If set to `interactive', +user is prompted for range boundaries. It can be a string or an +integer. + +By default, a week starts Monday 0:00 and ends Sunday 24:00. The +range is determined relative to TIME, which defaults to current +time. + +The return value is a list containing two internal times, one for +the beginning of the range and one for its end, like the ones +returned by `current time' or `encode-time' and a string used to +display information. If AS-STRINGS is non-nil, the returned +times will be formatted strings. + +If WSTART is non-nil, use this number to specify the starting day +of a week (monday is 1). If MSTART is non-nil, use this number +to specify the starting day of a month (1 is the first day of the +month). If you can combine both, the month starting day will +have priority." + (let* ((tm (decode-time time)) + (m (nth 1 tm)) + (h (nth 2 tm)) + (d (nth 3 tm)) + (month (nth 4 tm)) + (y (nth 5 tm)) (dow (nth 6 tm)) - (ws (or wstart 1)) - (ms (or mstart 1)) - (skey (symbol-name key)) + (skey (format "%s" key)) (shift 0) - (q (cond ((>= (nth 4 tm) 10) 4) - ((>= (nth 4 tm) 7) 3) - ((>= (nth 4 tm) 4) 2) - ((>= (nth 4 tm) 1) 1))) - s1 m1 h1 d1 month1 y1 diff ts te fm txt w date - interval tmp shiftedy shiftedm shiftedq) + (q (cond ((>= month 10) 4) + ((>= month 7) 3) + ((>= month 4) 2) + (t 1))) + m1 h1 d1 month1 y1 shiftedy shiftedm shiftedq) (cond - ((string-match "^[0-9]+$" skey) - (setq y (string-to-number skey) m 1 d 1 key 'year)) - ((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)$" skey) + ((string-match "\\`[0-9]+\\'" skey) + (setq y (string-to-number skey) month 1 d 1 key 'year)) + ((string-match "\\`\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)\\'" skey) (setq y (string-to-number (match-string 1 skey)) month (string-to-number (match-string 2 skey)) - d 1 key 'month)) - ((string-match "^\\([0-9]+\\)-[wW]\\([0-9]\\{1,2\\}\\)$" skey) + d 1 + key 'month)) + ((string-match "\\`\\([0-9]+\\)-[wW]\\([0-9]\\{1,2\\}\\)\\'" skey) (require 'cal-iso) - (setq y (string-to-number (match-string 1 skey)) - w (string-to-number (match-string 2 skey))) - (setq date (calendar-gregorian-from-absolute - (calendar-absolute-from-iso (list w 1 y)))) - (setq d (nth 1 date) month (car date) y (nth 2 date) - dow 1 - key 'week)) - ((string-match "^\\([0-9]+\\)-[qQ]\\([1-4]\\)$" skey) + (let ((date (calendar-gregorian-from-absolute + (calendar-iso-to-absolute + (list (string-to-number (match-string 2 skey)) + 1 + (string-to-number (match-string 1 skey))))))) + (setq d (nth 1 date) + month (car date) + y (nth 2 date) + dow 1 + key 'week))) + ((string-match "\\`\\([0-9]+\\)-[qQ]\\([1-4]\\)\\'" skey) (require 'cal-iso) - (setq y (string-to-number (match-string 1 skey))) - (setq q (string-to-number (match-string 2 skey))) - (setq date (calendar-gregorian-from-absolute - (calendar-absolute-from-iso (org-quarter-to-date q y)))) - (setq d (nth 1 date) month (car date) y (nth 2 date) - dow 1 - key 'quarter)) - ((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)$" skey) + (let ((date (calendar-gregorian-from-absolute + (calendar-iso-to-absolute + (org-quarter-to-date + (string-to-number (match-string 2 skey)) + (string-to-number (match-string 1 skey))))))) + (setq d (nth 1 date) + month (car date) + y (nth 2 date) + dow 1 + key 'quarter))) + ((string-match + "\\`\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)\\'" + skey) (setq y (string-to-number (match-string 1 skey)) month (string-to-number (match-string 2 skey)) d (string-to-number (match-string 3 skey)) key 'day)) - ((string-match "\\([-+][0-9]+\\)$" skey) + ((string-match "\\([-+][0-9]+\\)\\'" skey) (setq shift (string-to-number (match-string 1 skey)) - key (intern (substring skey 0 (match-beginning 1)))) - (if (and (memq key '(quarter thisq)) (> shift 0)) - (error "Looking forward with quarters isn't implemented")))) - + key (intern (substring skey 0 (match-beginning 1)))) + (when (and (memq key '(quarter thisq)) (> shift 0)) + (error "Looking forward with quarters isn't implemented")))) (when (= shift 0) - (cond ((eq key 'yesterday) (setq key 'today shift -1)) - ((eq key 'lastweek) (setq key 'week shift -1)) - ((eq key 'lastmonth) (setq key 'month shift -1)) - ((eq key 'lastyear) (setq key 'year shift -1)) - ((eq key 'lastq) (setq key 'quarter shift -1)))) - (cond - ((memq key '(day today)) - (setq d (+ d shift) h 0 m 0 h1 24 m1 0)) - ((memq key '(week thisweek)) - (setq diff (+ (* -7 shift) (if (= dow 0) (- 7 ws) (- dow ws))) - m 0 h 0 d (- d diff) d1 (+ 7 d))) - ((memq key '(month thismonth)) - (setq d (or ms 1) h 0 m 0 d1 (or ms 1) - month (+ month shift) month1 (1+ month) h1 0 m1 0)) - ((memq key '(quarter thisq)) - ;; Compute if this shift remains in this year. If not, compute - ;; how many years and quarters we have to shift (via floor*) and - ;; compute the shifted years, months and quarters. - (cond - ((< (+ (- q 1) shift) 0) ; shift not in this year - (setq interval (* -1 (+ (- q 1) shift))) - ;; Set tmp to ((years to shift) (quarters to shift)). - (setq tmp (org-floor* interval 4)) - ;; Due to the use of floor, 0 quarters actually means 4. - (if (= 0 (nth 1 tmp)) - (setq shiftedy (- y (nth 0 tmp)) - shiftedm 1 - shiftedq 1) - (setq shiftedy (- y (+ 1 (nth 0 tmp))) - shiftedm (- 13 (* 3 (nth 1 tmp))) - shiftedq (- 5 (nth 1 tmp)))) - (setq d 1 h 0 m 0 d1 1 month shiftedm month1 (+ 3 shiftedm) h1 0 m1 0 y shiftedy)) - ((> (+ q shift) 0) ; shift is within this year - (setq shiftedq (+ q shift)) - (setq shiftedy y) - (setq d 1 h 0 m 0 d1 1 month (+ 1 (* 3 (- (+ q shift) 1))) month1 (+ 4 (* 3 (- (+ q shift) 1))) h1 0 m1 0)))) - ((memq key '(year thisyear)) - (setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y))) - (t (error "No such time block %s" key))) - (setq ts (encode-time s m h d month y) - te (encode-time (or s1 s) (or m1 m) (or h1 h) - (or d1 d) (or month1 month) (or y1 y))) - (setq fm (cdr org-time-stamp-formats)) - (cond - ((memq key '(day today)) - (setq txt (format-time-string "%A, %B %d, %Y" ts))) - ((memq key '(week thisweek)) - (setq txt (format-time-string "week %G-W%V" ts))) - ((memq key '(month thismonth)) - (setq txt (format-time-string "%B %Y" ts))) - ((memq key '(year thisyear)) - (setq txt (format-time-string "the year %Y" ts))) - ((memq key '(quarter thisq)) - (setq txt (concat (org-count-quarter shiftedq) " quarter of " (number-to-string shiftedy))))) - (if as-strings - (list (format-time-string fm ts) (format-time-string fm te) txt) - (list ts te txt)))) + (case key + (yesterday (setq key 'today shift -1)) + (lastweek (setq key 'week shift -1)) + (lastmonth (setq key 'month shift -1)) + (lastyear (setq key 'year shift -1)) + (lastq (setq key 'quarter shift -1)))) + ;; Prepare start and end times depending on KEY's type. + (case key + ((day today) (setq m 0 h 0 h1 24 d (+ d shift))) + ((week thisweek) + (let* ((ws (or wstart 1)) + (diff (+ (* -7 shift) (if (= dow 0) (- 7 ws) (- dow ws))))) + (setq m 0 h 0 d (- d diff) d1 (+ 7 d)))) + ((month thismonth) + (setq h 0 m 0 d (or mstart 1) month (+ month shift) month1 (1+ month))) + ((quarter thisq) + ;; Compute if this shift remains in this year. If not, compute + ;; how many years and quarters we have to shift (via floor*) and + ;; compute the shifted years, months and quarters. + (cond + ((< (+ (- q 1) shift) 0) ; Shift not in this year. + (let* ((interval (* -1 (+ (- q 1) shift))) + ;; Set tmp to ((years to shift) (quarters to shift)). + (tmp (org-floor* interval 4))) + ;; Due to the use of floor, 0 quarters actually means 4. + (if (= 0 (nth 1 tmp)) + (setq shiftedy (- y (nth 0 tmp)) + shiftedm 1 + shiftedq 1) + (setq shiftedy (- y (+ 1 (nth 0 tmp))) + shiftedm (- 13 (* 3 (nth 1 tmp))) + shiftedq (- 5 (nth 1 tmp))))) + (setq m 0 h 0 d 1 month shiftedm month1 (+ 3 shiftedm) y shiftedy)) + ((> (+ q shift) 0) ; Shift is within this year. + (setq shiftedq (+ q shift)) + (setq shiftedy y) + (let ((qshift (* 3 (1- (+ q shift))))) + (setq m 0 h 0 d 1 month (+ 1 qshift) month1 (+ 4 qshift)))))) + ((year thisyear) + (setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y))) + ((interactive untilnow)) ; Special cases, ignore them. + (t (user-error "No such time block %s" key))) + ;; Format start and end times according to AS-STRINGS. + (let* ((start (case key + (interactive (org-read-date nil t nil "Range start? ")) + (untilnow org-clock--oldest-date) + (t (encode-time 0 m h d month y)))) + (end (case key + (interactive (org-read-date nil t nil "Range end? ")) + (untilnow (current-time)) + (t (encode-time 0 + (or m1 m) + (or h1 h) + (or d1 d) + (or month1 month) + (or y1 y))))) + (text + (case key + ((day today) (format-time-string "%A, %B %d, %Y" start)) + ((week thisweek) (format-time-string "week %G-W%V" start)) + ((month thismonth) (format-time-string "%B %Y" start)) + ((year thisyear) (format-time-string "the year %Y" start)) + ((quarter thisq) + (concat (org-count-quarter shiftedq) + " quarter of " (number-to-string shiftedy))) + (interactive "(Range interactively set)") + (untilnow "now")))) + (if (not as-strings) (list start end text) + (let ((f (cdr org-time-stamp-formats))) + (list (format-time-string f start) + (format-time-string f end) + text)))))) (defun org-count-quarter (n) (cond @@ -2192,7 +2322,7 @@ the currently selected interval size." ((and wp (string-match "w\\|W" wp) mw (> (length wp) 0)) (require 'cal-iso) (setq date (calendar-gregorian-from-absolute - (calendar-absolute-from-iso (list (+ mw n) 1 y)))) + (calendar-iso-to-absolute (list (+ mw n) 1 y)))) (setq ins (format-time-string "%G-W%V" (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date))))) @@ -2209,7 +2339,7 @@ the currently selected interval size." y (- y 1)) ()) (setq date (calendar-gregorian-from-absolute - (calendar-absolute-from-iso (org-quarter-to-date (+ mw n) y)))) + (calendar-iso-to-absolute (org-quarter-to-date (+ mw n) y)))) (setq ins (format-time-string (concat (number-to-string y) "-Q" (number-to-string (+ mw n))) (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date))))) @@ -2336,6 +2466,7 @@ from the dynamic block definition." org-clock-clocktable-language-setup)) (multifile (plist-get params :multifile)) (block (plist-get params :block)) + (sort (plist-get params :sort)) (ts (plist-get params :tstart)) (te (plist-get params :tend)) (header (plist-get params :header)) @@ -2542,6 +2673,11 @@ from the dynamic block definition." (when org-hide-emphasis-markers ;; we need to align a second time (org-table-align)) + (when sort + (save-excursion + (org-table-goto-line 3) + (org-table-goto-column (car sort)) + (org-table-sort-lines nil (cdr sort)))) (when recalc (if (eq formula '%) (save-excursion @@ -2556,10 +2692,10 @@ from the dynamic block definition." total-time)) (defun org-clocktable-indent-string (level) + "Return indentation string according to LEVEL. +LEVEL is an integer. Indent by two spaces per level above 1." (if (= level 1) "" - (let ((str " ")) - (dotimes (k (1- level) str) - (setq str (concat "\\emsp" str)))))) + (concat "\\_" (make-string (* 2 (1- level)) ?\s)))) (defun org-clocktable-steps (params) "Step through the range to make a number of clock tables." @@ -2670,10 +2806,8 @@ TIME: The sum of all time spend in this tree, in minutes. This time (when (and te (listp te)) (setq te (format "%4d-%02d-%02d" (nth 2 te) (car te) (nth 1 te)))) ;; Now the times are strings we can parse. - (if ts (setq ts (org-float-time - (seconds-to-time (org-matcher-time ts))))) - (if te (setq te (org-float-time - (seconds-to-time (org-matcher-time te))))) + (if ts (setq ts (org-matcher-time ts))) + (if te (setq te (org-matcher-time te))) (save-excursion (org-clock-sum ts te (unless (null matcher) @@ -2813,8 +2947,8 @@ The details of what will be saved are regulated by the variable (delete-region (point-min) (point-max)) ;;Store clock (insert (format ";; org-persist.el - %s at %s\n" - system-name (format-time-string - (cdr org-time-stamp-formats)))) + (system-name) (format-time-string + (cdr org-time-stamp-formats)))) (if (and (memq org-clock-persist '(t clock)) (setq b (org-clocking-buffer)) (setq b (or (buffer-base-buffer b) b)) diff --git a/lisp/org-colview.el b/lisp/org-colview.el index 07ee69f..251f425 100644 --- a/lisp/org-colview.el +++ b/lisp/org-colview.el @@ -158,109 +158,99 @@ This is the compiled version of the format.") (defun org-columns-display-here (&optional props dateline) "Overlay the current line with column display." (interactive) - (let* ((fmt org-columns-current-fmt-compiled) - (beg (point-at-bol)) - (level-face (save-excursion - (beginning-of-line 1) - (and (looking-at "\\(\\**\\)\\(\\* \\)") - (org-get-level-face 2)))) - (ref-face (or level-face - (and (eq major-mode 'org-agenda-mode) - (get-text-property (point-at-bol) 'face)) - 'default)) - (color (list :foreground (face-attribute ref-face :foreground))) - (font (list :height (face-attribute 'default :height) - :family (face-attribute 'default :family))) - (face (list color font 'org-column ref-face)) - (face1 (list color font 'org-agenda-column-dateline ref-face)) - (cphr (get-text-property (point-at-bol) 'org-complex-heading-regexp)) - pom property ass width f fc string fm ov column val modval s2 title calc) - ;; Check if the entry is in another buffer. - (unless props - (if (eq major-mode 'org-agenda-mode) - (setq pom (or (org-get-at-bol 'org-hd-marker) - (org-get-at-bol 'org-marker)) - props (if pom (org-entry-properties pom) nil)) - (setq props (org-entry-properties nil)))) - ;; Walk the format - (while (setq column (pop fmt)) - (setq property (car column) - title (nth 1 column) - ass (if (equal property "ITEM") - (cons "ITEM" - ;; When in a buffer, get the whole line, - ;; we'll clean it later… - (if (derived-mode-p 'org-mode) - (save-match-data - (org-remove-tabs - (buffer-substring-no-properties - (point-at-bol) (point-at-eol)))) - ;; In agenda, just get the `txt' property - (or (org-get-at-bol 'txt) - (buffer-substring-no-properties - (point) (progn (end-of-line) (point)))))) - (assoc property props)) - width (or (cdr (assoc property org-columns-current-maxwidths)) - (nth 2 column) - (length property)) - f (format "%%-%d.%ds | " width width) - fm (nth 4 column) - fc (nth 5 column) - calc (nth 7 column) - val (or (cdr ass) "") - modval (cond ((and org-columns-modify-value-for-display-function - (functionp - org-columns-modify-value-for-display-function)) - (funcall org-columns-modify-value-for-display-function - title val)) - ((equal property "ITEM") - (org-columns-cleanup-item - val org-columns-current-fmt-compiled - (or org-complex-heading-regexp cphr))) - (fc (org-columns-number-to-string - (org-columns-string-to-number val fm) fm fc)) - ((and calc (functionp calc) - (not (string= val "")) - (not (get-text-property 0 'org-computed val))) - (org-columns-number-to-string - (funcall calc (org-columns-string-to-number - val fm)) fm)))) - (setq s2 (org-columns-add-ellipses (or modval val) width)) - (setq string (format f s2)) - ;; Create the overlay + (save-excursion + (beginning-of-line) + (let* ((level-face (and (looking-at "\\(\\**\\)\\(\\* \\)") + (org-get-level-face 2))) + (ref-face (or level-face + (and (eq major-mode 'org-agenda-mode) + (org-get-at-bol 'face)) + 'default)) + (color (list :foreground (face-attribute ref-face :foreground))) + (font (list :height (face-attribute 'default :height) + :family (face-attribute 'default :family))) + (face (list color font 'org-column ref-face)) + (face1 (list color font 'org-agenda-column-dateline ref-face)) + (pom (and (eq major-mode 'org-agenda-mode) + (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker)))) + (props (cond (props) + ((eq major-mode 'org-agenda-mode) + (and pom (org-entry-properties pom))) + (t (org-entry-properties))))) + ;; Each column is an overlay on top of a character. So there has + ;; to be at least as many characters available on the line as + ;; columns to display. + (let ((columns (length org-columns-current-fmt-compiled)) + (chars (- (line-end-position) (line-beginning-position)))) + (when (> columns chars) + (save-excursion + (end-of-line) + (let ((inhibit-read-only t)) + (insert (make-string (- columns chars) ?\s)))))) + ;; Walk the format. Create and install the overlay for the + ;; current column on the next character. + (dolist (column org-columns-current-fmt-compiled) + (let* ((property (car column)) + (title (nth 1 column)) + (ass (assoc-string property props t)) + (width + (or + (cdr (assoc-string property org-columns-current-maxwidths t)) + (nth 2 column) + (length property))) + (f (format "%%-%d.%ds | " width width)) + (fm (nth 4 column)) + (fc (nth 5 column)) + (calc (nth 7 column)) + (val (or (cdr ass) "")) + (modval + (cond + ((and org-columns-modify-value-for-display-function + (functionp + org-columns-modify-value-for-display-function)) + (funcall org-columns-modify-value-for-display-function + title val)) + ((equal property "ITEM") (org-columns-compact-links val)) + (fc (org-columns-number-to-string + (org-columns-string-to-number val fm) fm fc)) + ((and calc (functionp calc) + (not (string= val "")) + (not (get-text-property 0 'org-computed val))) + (org-columns-number-to-string + (funcall calc (org-columns-string-to-number val fm)) fm)))) + (string + (format f (org-columns-add-ellipses (or modval val) width))) + (ov (org-columns-new-overlay + (point) (1+ (point)) string (if dateline face1 face)))) + (overlay-put ov 'keymap org-columns-map) + (overlay-put ov 'org-columns-key property) + (overlay-put ov 'org-columns-value (cdr ass)) + (overlay-put ov 'org-columns-value-modified modval) + (overlay-put ov 'org-columns-pom pom) + (overlay-put ov 'org-columns-format f) + (overlay-put ov 'line-prefix "") + (overlay-put ov 'wrap-prefix "") + (forward-char))) + ;; Make the rest of the line disappear. + (let ((ov (org-columns-new-overlay (point) (line-end-position)))) + (overlay-put ov 'invisible t) + (overlay-put ov 'keymap org-columns-map) + (overlay-put ov 'line-prefix "") + (overlay-put ov 'wrap-prefix "")) + (let ((ov (make-overlay (1- (line-end-position)) + (line-beginning-position 2)))) + (overlay-put ov 'keymap org-columns-map) + (push ov org-columns-overlays)) (org-with-silent-modifications - (setq ov (org-columns-new-overlay - beg (setq beg (1+ beg)) string (if dateline face1 face))) - (overlay-put ov 'keymap org-columns-map) - (overlay-put ov 'org-columns-key property) - (overlay-put ov 'org-columns-value (cdr ass)) - (overlay-put ov 'org-columns-value-modified modval) - (overlay-put ov 'org-columns-pom pom) - (overlay-put ov 'org-columns-format f) - (overlay-put ov 'line-prefix "") - (overlay-put ov 'wrap-prefix "")) - (if (or (not (char-after beg)) - (equal (char-after beg) ?\n)) - (let ((inhibit-read-only t)) - (save-excursion - (goto-char beg) - (org-unmodified (insert " ")))))) ;; FIXME: add props and remove later? - ;; Make the rest of the line disappear. - (org-unmodified - (setq ov (org-columns-new-overlay beg (point-at-eol))) - (overlay-put ov 'invisible t) - (overlay-put ov 'keymap org-columns-map) - (overlay-put ov 'intangible t) - (overlay-put ov 'line-prefix "") - (overlay-put ov 'wrap-prefix "") - (push ov org-columns-overlays) - (setq ov (make-overlay (1- (point-at-eol)) (1+ (point-at-eol)))) - (overlay-put ov 'keymap org-columns-map) - (push ov org-columns-overlays) - (let ((inhibit-read-only t)) - (put-text-property (max (point-min) (1- (point-at-bol))) - (min (point-max) (1+ (point-at-eol))) - 'read-only "Type `e' to edit property"))))) + (let ((inhibit-read-only t)) + (put-text-property + (line-end-position 0) + (line-beginning-position 2) + 'read-only + (substitute-command-keys + "Type \\<org-columns-map>\\[org-columns-edit-value] \ +to edit property"))))))) (defun org-columns-add-ellipses (string width) "Truncate STRING with WIDTH characters, with ellipses." @@ -294,7 +284,9 @@ for the duration of the command.") (while (setq column (pop fmt)) (setq property (car column) str (or (nth 1 column) property) - width (or (cdr (assoc property org-columns-current-maxwidths)) + width (or (cdr (assoc-string property + org-columns-current-maxwidths + t)) (nth 2 column) (length str)) widths (push width widths) @@ -348,29 +340,6 @@ for the duration of the command.") (when (local-variable-p 'org-colview-initial-truncate-line-value) (setq truncate-lines org-colview-initial-truncate-line-value))))) -(defun org-columns-cleanup-item (item fmt cphr) - "Remove from ITEM what is a column in the format FMT. -CPHR is the complex heading regexp to use for parsing ITEM." - (let (fixitem) - (if (not cphr) - item - (unless (string-match "^\*+ " item) - (setq item (concat "* " item) fixitem t)) - (if (string-match cphr item) - (setq item - (concat - (org-add-props (match-string 1 item) nil - 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1)))))) - (and (match-end 2) (not (assoc "TODO" fmt)) (concat " " (match-string 2 item))) - (and (match-end 3) (not (assoc "PRIORITY" fmt)) (concat " " (match-string 3 item))) - " " (save-match-data (org-columns-compact-links (or (match-string 4 item) ""))) - (and (match-end 5) (not (assoc "TAGS" fmt)) (concat " " (match-string 5 item))))) - (add-text-properties - 0 (1+ (match-end 1)) - (list 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1)))))) - item)) - (if fixitem (replace-regexp-in-string "^\*+ " "" item) item)))) - (defun org-columns-compact-links (s) "Replace [[link][desc]] with [desc] or [link]." (while (string-match org-bracket-link-regexp s) @@ -434,7 +403,7 @@ Where possible, use the standard interface for changing this line." (value (get-char-property (point) 'org-columns-value)) (bol (point-at-bol)) (eol (point-at-eol)) (pom (or (get-text-property bol 'org-hd-marker) - (point))) ; keep despite of compiler waring + (point))) ; keep despite of compiler waring (line-overlays (delq nil (mapcar (lambda (x) (and (eq (overlay-buffer x) (current-buffer)) @@ -510,7 +479,7 @@ Where possible, use the standard interface for changing this line." (org-columns-display-here))) (org-move-to-column col) (if (and (derived-mode-p 'org-mode) - (nth 3 (assoc key org-columns-current-fmt-compiled))) + (nth 3 (assoc-string key org-columns-current-fmt-compiled t))) (org-columns-update key))))))) (defun org-edit-headline () ; FIXME: this is not columns specific. Make interactive????? Use from agenda???? @@ -579,7 +548,7 @@ an integer, select that value." (value (get-char-property (point) 'org-columns-value)) (bol (point-at-bol)) (eol (point-at-eol)) (pom (or (get-text-property bol 'org-hd-marker) - (point))) ; keep despite of compiler waring + (point))) ; keep despite of compiler waring (line-overlays (delq nil (mapcar (lambda (x) (and (eq (overlay-buffer x) (current-buffer)) @@ -589,7 +558,9 @@ an integer, select that value." org-columns-overlays))) (allowed (or (org-property-get-allowed-values pom key) (and (memq - (nth 4 (assoc key org-columns-current-fmt-compiled)) + (nth 4 (assoc-string key + org-columns-current-fmt-compiled + t)) '(checkbox checkbox-n-of-m checkbox-percent)) '("[ ]" "[X]")) (org-colview-construct-allowed-dates value))) @@ -638,7 +609,7 @@ an integer, select that value." (org-columns-eval '(org-entry-put pom key nval))) (org-columns-display-here))) (org-move-to-column col) - (and (nth 3 (assoc key org-columns-current-fmt-compiled)) + (and (nth 3 (assoc-string key org-columns-current-fmt-compiled t)) (org-columns-update key)))))) (defun org-colview-construct-allowed-dates (s) @@ -705,49 +676,48 @@ When COLUMNS-FMT-STRING is non-nil, use it as the column format." (org-verify-version 'columns) (org-columns-remove-overlays) (move-marker org-columns-begin-marker (point)) - (let ((org-columns-time (time-to-number-of-days (current-time))) - beg end fmt cache maxwidths) - (org-columns-goto-top-level) - (setq fmt (org-columns-get-format columns-fmt-string)) - (save-excursion - (goto-char org-columns-top-level-marker) - (setq beg (point)) - (unless org-columns-inhibit-recalculation - (org-columns-compute-all)) - (setq end (or (condition-case nil (org-end-of-subtree t t) (error nil)) - (point-max))) - ;; Get and cache the properties - (goto-char beg) + (org-columns-goto-top-level) + ;; Initialize `org-columns-current-fmt' and + ;; `org-columns-current-fmt-compiled'. + (let ((org-columns-time (time-to-number-of-days (current-time)))) + (org-columns-get-format columns-fmt-string)) + (unless org-columns-inhibit-recalculation (org-columns-compute-all)) + (save-excursion + (save-restriction + (narrow-to-region + org-columns-top-level-marker + (or (ignore-errors (org-end-of-subtree t t)) (point-max))) + (goto-char (point-min)) (when (assoc "CLOCKSUM" org-columns-current-fmt-compiled) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (org-clock-sum)))) + (org-clock-sum)) (when (assoc "CLOCKSUM_T" org-columns-current-fmt-compiled) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (org-clock-sum-today)))) - (while (re-search-forward org-outline-regexp-bol end t) - (if (and org-columns-skip-archived-trees - (looking-at (concat ".*:" org-archive-tag ":"))) - (org-end-of-subtree t) - (push (cons (org-current-line) (org-entry-properties)) cache))) - (when cache - (setq maxwidths (org-columns-get-autowidth-alist fmt cache)) - (org-set-local 'org-columns-current-maxwidths maxwidths) - (org-columns-display-here-title) - (when (org-set-local 'org-columns-flyspell-was-active - (org-bound-and-true-p flyspell-mode)) - (flyspell-mode 0)) - (unless (local-variable-p 'org-colview-initial-truncate-line-value) - (org-set-local 'org-colview-initial-truncate-line-value - truncate-lines)) - (setq truncate-lines t) - (mapc (lambda (x) - (org-goto-line (car x)) - (org-columns-display-here (cdr x))) - cache))))) + (org-clock-sum-today)) + (let* ((column-names (mapcar #'car org-columns-current-fmt-compiled)) + (cache + (org-map-entries + (lambda () + (cons (point) + (mapcar + (lambda (p) + (cons p (org-entry-get nil p 'selective t))) + column-names))) + nil nil (and org-columns-skip-archived-trees 'archive)))) + (when cache + (org-set-local 'org-columns-current-maxwidths + (org-columns-get-autowidth-alist + org-columns-current-fmt + cache)) + (org-columns-display-here-title) + (when (org-set-local 'org-columns-flyspell-was-active + (org-bound-and-true-p flyspell-mode)) + (flyspell-mode 0)) + (unless (local-variable-p 'org-colview-initial-truncate-line-value) + (org-set-local 'org-colview-initial-truncate-line-value + truncate-lines)) + (setq truncate-lines t) + (dolist (x cache) + (goto-char (car x)) + (org-columns-display-here (cdr x)))))))) (eval-when-compile (defvar org-columns-time)) @@ -791,7 +761,8 @@ calc function called on every element before summarizing. This is (defun org-columns-new (&optional prop title width op fmt fun &rest rest) "Insert a new column, to the left of the current column." (interactive) - (let ((editp (and prop (assoc prop org-columns-current-fmt-compiled))) + (let ((editp (and prop + (assoc-string prop org-columns-current-fmt-compiled t))) cell) (setq prop (org-icompleting-read "Property: " (mapcar 'list (org-buffer-property-keys t nil t)) @@ -849,7 +820,9 @@ calc function called on every element before summarizing. This is (let* ((n (current-column)) (entry (nth n org-columns-current-fmt-compiled)) (width (or (nth 2 entry) - (cdr (assoc (car entry) org-columns-current-maxwidths))))) + (cdr (assoc-string (car entry) + org-columns-current-maxwidths + t))))) (setq width (max 1 (+ width arg))) (setcar (nthcdr 2 entry) width) (org-columns-store-format) @@ -900,7 +873,7 @@ display, or in the #+COLUMNS line of the current buffer." (org-entry-put nil "COLUMNS" fmt) (goto-char (point-min)) ;; Overwrite all #+COLUMNS lines.... - (while (re-search-forward "^#\\+COLUMNS:.*" nil t) + (while (re-search-forward "^[ \t]*#\\+COLUMNS:.*" nil t) (setq cnt (1+ cnt)) (replace-match (concat "#+COLUMNS: " fmt) t t)) (unless (> cnt 0) @@ -917,11 +890,14 @@ display, or in the #+COLUMNS line of the current buffer." (push (cons (match-string 1 s) 1) rtn) (setq start (match-end 0))) (mapc (lambda (x) - (setcdr x (apply 'max + (setcdr x + (apply #'max + (let ((prop (car x))) (mapcar (lambda (y) - (length (or (cdr (assoc (car x) (cdr y))) " "))) - cache)))) + (length (or (cdr (assoc-string prop (cdr y) t)) + " "))) + cache))))) rtn) rtn)) @@ -946,9 +922,11 @@ display, or in the #+COLUMNS line of the current buffer." (when (equal (overlay-get ov 'org-columns-key) property) (setq pos (overlay-start ov)) (goto-char pos) - (when (setq val (cdr (assoc property - (get-text-property - (point-at-bol) 'org-summaries)))) + (when (setq val (cdr (assoc-string + property + (get-text-property + (point-at-bol) 'org-summaries) + t))) (setq fmt (overlay-get ov 'org-columns-format)) (overlay-put ov 'org-columns-value val) (overlay-put ov 'display (format fmt val))))) @@ -962,11 +940,11 @@ display, or in the #+COLUMNS line of the current buffer." "Sum the values of property PROPERTY hierarchically, for the entire buffer." (interactive) (let* ((re org-outline-regexp-bol) - (lmax 30) ; Does anyone use deeper levels??? + (lmax 30) ; Does anyone use deeper levels??? (lvals (make-vector lmax nil)) (lflag (make-vector lmax nil)) (level 0) - (ass (assoc property org-columns-current-fmt-compiled)) + (ass (assoc-string property org-columns-current-fmt-compiled t)) (format (nth 4 ass)) (printf (nth 5 ass)) (fun (nth 6 ass)) @@ -990,24 +968,28 @@ display, or in the #+COLUMNS line of the current buffer." valflag (and val (string-match "\\S-" val))) (cond ((< level last-level) - ;; put the sum of lower levels here as a property - (setq sum (+ (if (and (/= last-level inminlevel) - (aref lvals last-level)) - (apply fun (aref lvals last-level)) 0) - (if (aref lvals inminlevel) - (apply fun (aref lvals inminlevel)) 0)) + ;; Put the sum of lower levels here as a property. If + ;; values are estimate, use an appropriate sum function. + (setq sum (funcall + (if (eq fun 'org-estimate-combine) #'org-estimate-combine + #'+) + (if (and (/= last-level inminlevel) + (aref lvals last-level)) + (apply fun (aref lvals last-level)) 0) + (if (aref lvals inminlevel) + (apply fun (aref lvals inminlevel)) 0)) flag (or (aref lflag last-level) ; any valid entries from children? (aref lflag inminlevel)) ; or inline tasks? str (org-columns-number-to-string sum format printf) str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold) useval (if flag str1 (if valflag val "")) sum-alist (get-text-property sumpos 'org-summaries)) - (if (assoc property sum-alist) - (setcdr (assoc property sum-alist) useval) - (push (cons property useval) sum-alist) - (org-with-silent-modifications - (add-text-properties sumpos (1+ sumpos) - (list 'org-summaries sum-alist)))) + (let ((old (assoc-string property sum-alist t))) + (if old (setcdr old useval) + (push (cons property useval) sum-alist) + (org-with-silent-modifications + (add-text-properties sumpos (1+ sumpos) + (list 'org-summaries sum-alist))))) (when (and val (not (equal val (if flag str val)))) (org-entry-put nil property (if flag str val))) ;; add current to current level accumulator @@ -1086,7 +1068,7 @@ display, or in the #+COLUMNS line of the current buffer." (defun org-nofm-to-completion (n m &optional percent) (if (not percent) (format "[%d/%d]" n m) - (format "[%d%%]"(floor (+ 0.5 (* 100. (/ (* 1.0 n) m))))))) + (format "[%d%%]" (round (* 100.0 n) m)))) (defun org-columns-string-to-number (s fmt) @@ -1109,6 +1091,9 @@ display, or in the #+COLUMNS line of the current buffer." (while l (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) sum)) + ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent)) + (if (equal s "[X]") 1. 0.000001)) + ((memq fmt '(estimate)) (org-string-to-estimate s)) ((string-match (concat "\\([0-9.]+\\) *\\(" (regexp-opt (mapcar 'car org-effort-durations)) "\\)") s) @@ -1117,14 +1102,11 @@ display, or in the #+COLUMNS line of the current buffer." (while l (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) sum)) - ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent)) - (if (equal s "[X]") 1. 0.000001)) - ((memq fmt '(estimate)) (org-string-to-estimate s)) (t (string-to-number s))))) (defun org-columns-uncompile-format (cfmt) "Turn the compiled columns format back into a string representation." - (let ((rtn "") e s prop title op op-match width fmt printf fun calc) + (let ((rtn "") e s prop title op op-match width fmt printf fun calc ee map) (while (setq e (pop cfmt)) (setq prop (car e) title (nth 1 e) @@ -1134,8 +1116,10 @@ display, or in the #+COLUMNS line of the current buffer." printf (nth 5 e) fun (nth 6 e) calc (nth 7 e)) - (when (setq op-match (rassoc (list fmt fun calc) org-columns-compile-map)) - (setq op (car op-match))) + (setq map (copy-sequence org-columns-compile-map)) + (while (setq ee (pop map)) + (if (equal fmt (nth 1 ee)) + (setq op (car ee) map nil))) (if (and op printf) (setq op (concat op ";" printf))) (if (equal title prop) (setq title nil)) (setq s (concat "%" (if width (number-to-string width)) @@ -1146,7 +1130,8 @@ display, or in the #+COLUMNS line of the current buffer." (org-trim rtn))) (defun org-columns-compile-format (fmt) - "Turn a column format string into an alist of specifications. + "Turn a column format string FMT into an alist of specifications. + The alist has one entry for each column in the format. The elements of that list are: property the property @@ -1156,7 +1141,9 @@ operator the operator if any format the output format for computed results, derived from operator printf a printf format for computed values fun the lisp function to compute summary values, derived from operator -calc function to get values from base elements" +calc function to get values from base elements + +This function updates `org-columns-current-fmt-compiled'." (let ((start 0) width prop title op op-match f printf fun calc) (setq org-columns-current-fmt-compiled nil) (while (string-match @@ -1199,8 +1186,6 @@ containing the title row and all other rows. Each row is a list of fields." (save-excursion (let* ((title (mapcar 'cadr org-columns-current-fmt-compiled)) - (re-comment (format org-heading-keyword-regexp-format - org-comment-string)) (re-archive (concat ".*:" org-archive-tag ":")) (n (length title)) row tbl) (goto-char (point-min)) @@ -1212,9 +1197,9 @@ of fields." (/ (1+ (length (match-string 1))) 2) (length (match-string 1))))) (get-char-property (match-beginning 0) 'org-columns-key)) - (when (save-excursion - (goto-char (point-at-bol)) - (or (looking-at re-comment) + (when (or (org-in-commented-heading-p t) + (save-excursion + (beginning-of-line) (looking-at re-archive))) (org-end-of-subtree t) (throw 'next t)) @@ -1377,60 +1362,73 @@ and tailing newline characters." (org-columns-remove-overlays) (move-marker org-columns-begin-marker (point)) (let ((org-columns-time (time-to-number-of-days (current-time))) - cache maxwidths m p a d fmt) - (cond - ((and (boundp 'org-agenda-overriding-columns-format) - org-agenda-overriding-columns-format) - (setq fmt org-agenda-overriding-columns-format)) - ((setq m (org-get-at-bol 'org-hd-marker)) - (setq fmt (or (org-entry-get m "COLUMNS" t) - (with-current-buffer (marker-buffer m) - org-columns-default-format)))) - ((and (boundp 'org-columns-current-fmt) - (local-variable-p 'org-columns-current-fmt) - org-columns-current-fmt) - (setq fmt org-columns-current-fmt)) - ((setq m (next-single-property-change (point-min) 'org-hd-marker)) - (setq m (get-text-property m 'org-hd-marker)) - (setq fmt (or (org-entry-get m "COLUMNS" t) - (with-current-buffer (marker-buffer m) - org-columns-default-format))))) - (setq fmt (or fmt org-columns-default-format)) + (fmt + (cond + ((org-bound-and-true-p org-agenda-overriding-columns-format)) + ((let ((m (org-get-at-bol 'org-hd-marker))) + (and m + (or (org-entry-get m "COLUMNS" t) + (with-current-buffer (marker-buffer m) + org-columns-default-format))))) + ((and (local-variable-p 'org-columns-current-fmt) + org-columns-current-fmt)) + ((let ((m (next-single-property-change (point-min) 'org-hd-marker))) + (and m + (let ((m (get-text-property m 'org-hd-marker))) + (or (org-entry-get m "COLUMNS" t) + (with-current-buffer (marker-buffer m) + org-columns-default-format)))))) + (t org-columns-default-format)))) (org-set-local 'org-columns-current-fmt fmt) (org-columns-compile-format fmt) (when org-agenda-columns-compute-summary-properties (org-agenda-colview-compute org-columns-current-fmt-compiled)) (save-excursion - ;; Get and cache the properties + ;; Collect properties for each headline in current view. (goto-char (point-min)) - (while (not (eobp)) - (when (setq m (or (org-get-at-bol 'org-hd-marker) - (org-get-at-bol 'org-marker))) - (setq p (org-entry-properties m)) - - (when (or (not (setq a (assoc org-effort-property p))) - (not (string-match "\\S-" (or (cdr a) "")))) - ;; OK, the property is not defined. Use appointment duration? - (when (and org-agenda-columns-add-appointments-to-effort-sum - (setq d (get-text-property (point) 'duration))) - (setq d (org-minutes-to-clocksum-string d)) - (put-text-property 0 (length d) 'face 'org-warning d) - (push (cons org-effort-property d) p))) - (push (cons (org-current-line) p) cache)) - (beginning-of-line 2)) - (when cache - (setq maxwidths (org-columns-get-autowidth-alist fmt cache)) - (org-set-local 'org-columns-current-maxwidths maxwidths) - (org-columns-display-here-title) - (when (org-set-local 'org-columns-flyspell-was-active - (org-bound-and-true-p flyspell-mode)) - (flyspell-mode 0)) - (mapc (lambda (x) - (org-goto-line (car x)) - (org-columns-display-here (cdr x))) - cache) - (when org-agenda-columns-show-summaries - (org-agenda-colview-summarize cache)))))) + (let (cache) + (let ((names (mapcar #'car org-columns-current-fmt-compiled)) m) + (while (not (eobp)) + (when (setq m (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker))) + (push + (cons + (line-beginning-position) + (org-with-point-at m + (mapcar + (lambda (name) + (let ((value (org-entry-get (point) name 'selective t))) + (cons + name + (if (and org-agenda-columns-add-appointments-to-effort-sum + (not value) + (eq (compare-strings name nil nil + org-effort-property nil nil + t) + t) + ;; Effort property is not defined. Try + ;; to use appointment duration. + (get-text-property (point) 'duration)) + (org-propertize + (org-minutes-to-clocksum-string + (get-text-property (point) 'duration)) + 'face 'org-warning) + value)))) + names))) + cache)) + (forward-line))) + (when cache + (org-set-local 'org-columns-current-maxwidths + (org-columns-get-autowidth-alist fmt cache)) + (org-columns-display-here-title) + (when (org-set-local 'org-columns-flyspell-was-active + (org-bound-and-true-p flyspell-mode)) + (flyspell-mode 0)) + (dolist (x cache) + (goto-char (car x)) + (org-columns-display-here (cdr x))) + (when org-agenda-columns-show-summaries + (org-agenda-colview-summarize cache))))))) (defun org-agenda-colview-summarize (cache) "Summarize the summarizable columns in column view in the agenda. @@ -1478,7 +1476,7 @@ This will add overlays to the date lines, to show the summary for each day." (t ;; do the summary (setq lsum nil) (dolist (x entries) - (setq v (cdr (assoc prop x))) + (setq v (cdr (assoc-string prop x t))) (if v (push (funcall @@ -1529,8 +1527,9 @@ This will add overlays to the date lines, to show the summary for each day." ((equal (car fm) "CLOCKSUM_T") (org-clock-sum-today)) ((and (nth 4 fm) - (setq a (assoc (car fm) - org-columns-current-fmt-compiled)) + (setq a (assoc-string (car fm) + org-columns-current-fmt-compiled + t)) (equal (nth 4 a) (nth 4 fm))) (org-columns-compute (car fm))))))))))) @@ -1547,7 +1546,10 @@ This will add overlays to the date lines, to show the summary for each day." (defun org-estimate-mean-and-var (v) "Return the mean and variance of an estimate." - (let* ((low (float (car v))) + (let* ((v (cond ((consp v) v) + ((numberp v) (list v v)) + (t (error "Invalid estimate type")))) + (low (float (car v))) (high (float (cadr v))) (mean (/ (+ low high) 2.0)) (var (/ (+ (expt (- mean low) 2.0) (expt (- high mean) 2.0)) 2.0))) @@ -1570,8 +1572,11 @@ and variances (respectively) of the individual estimates." (defun org-estimate-print (e &optional fmt) "Prepare a string representation of an estimate. This formats these numbers as two numbers with a \"-\" between them." - (if (null fmt) (set 'fmt "%.0f")) - (format "%s" (mapconcat (lambda (n) (format fmt n)) e "-"))) + (let ((fmt (or fmt "%.0f")) + (e (cond ((consp e) e) + ((numberp e) (list e e)) + (t (error "Invalid estimate type"))))) + (format "%s" (mapconcat (lambda (n) (format fmt n)) e "-")))) (defun org-string-to-estimate (s) "Convert a string to an estimate. diff --git a/lisp/org-compat.el b/lisp/org-compat.el index 90380a8..a762b8e 100644 --- a/lisp/org-compat.el +++ b/lisp/org-compat.el @@ -1,6 +1,6 @@ ;;; org-compat.el --- Compatibility code for Org-mode -;; Copyright (C) 2004-2014 Free Software Foundation, Inc. +;; Copyright (C) 2004-2015 Free Software Foundation, Inc. ;; Author: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: outlines, hypermedia, calendar, wp @@ -40,11 +40,6 @@ ;; it in org-mode, because the Byte compiler evaluates (featurep 'xemacs) ;; at compilation time and can therefore optimize code better. (defconst org-xemacs-p (featurep 'xemacs)) -(defconst org-format-transports-properties-p - (let ((x "a")) - (add-text-properties 0 1 '(test t) x) - (get-text-property 0 'test (format "%s" x))) - "Does format transport text properties?") (defun org-compatible-face (inherits specs) "Make a compatible face specification. @@ -241,7 +236,7 @@ ignored in this case." (or window (selected-window))) (defun org-number-sequence (from &optional to inc) - "Call `number-sequence or emulate it." + "Call `number-sequence' or emulate it." (if (fboundp 'number-sequence) (number-sequence from to inc) (if (or (not to) (= from to)) @@ -287,17 +282,8 @@ Works on both Emacs and XEmacs." (> (point) (region-beginning))) (exchange-point-and-mark))) -;; Emacs 22 misses `activate-mark' -(if (fboundp 'activate-mark) - (defalias 'org-activate-mark 'activate-mark) - (defun org-activate-mark () - (when (mark t) - (setq mark-active t) - (when (and (boundp 'transient-mark-mode) - (not transient-mark-mode)) - (setq transient-mark-mode 'lambda)) - (when (boundp 'zmacs-regions) - (setq zmacs-regions t))))) +;; Old alias for emacs 22 compatibility, now dropped +(define-obsolete-function-alias 'org-activate-mark 'activate-mark) ;; Invisibility compatibility @@ -411,17 +397,17 @@ Pass BUFFER to the XEmacs version of `move-to-column'." (when focus-follows-mouse (set-mouse-position frame (1- (frame-width frame)) 0))))) -(defun org-float-time (&optional time) - "Convert time value TIME to a floating point number. -TIME defaults to the current time." - (if (featurep 'xemacs) - (time-to-seconds (or time (current-time))) - (float-time time))) +(defalias 'org-float-time + (if (featurep 'xemacs) 'time-to-seconds 'float-time)) ;; `user-error' is only available from 24.2.50 on (unless (fboundp 'user-error) (defalias 'user-error 'error)) +;; `font-lock-ensure' is only available from 24.4.50 on +(unless (fboundp 'font-lock-ensure) + (defalias 'font-lock-ensure 'font-lock-fontify-buffer)) + (defmacro org-no-popups (&rest body) "Suppress popup windows. Let-bind some variables to nil around BODY to achieve the desired diff --git a/lisp/org-ctags.el b/lisp/org-ctags.el index 41775bd..faf543b 100644 --- a/lisp/org-ctags.el +++ b/lisp/org-ctags.el @@ -63,19 +63,19 @@ ;; with the same name as the link; then, if unsuccessful, ask the user if ;; he/she wants to rebuild the 'TAGS' database and try again; then ask if ;; the user wishes to append 'tag' as a new toplevel heading at the end of -;; the buffer; and finally, defer to org's default behaviour which is to +;; the buffer; and finally, defer to org's default behavior which is to ;; search the entire text of the current buffer for 'tag'. ;; -;; This behaviour can be modified by changing the value of +;; This behavior can be modified by changing the value of ;; ORG-CTAGS-OPEN-LINK-FUNCTIONS. For example I have the following in my -;; .emacs, which describes the same behaviour as the above paragraph with +;; .emacs, which describes the same behavior as the above paragraph with ;; one difference: ;; ;; (setq org-ctags-open-link-functions ;; '(org-ctags-find-tag ;; org-ctags-ask-rebuild-tags-file-then-find-tag ;; org-ctags-ask-append-topic -;; org-ctags-fail-silently)) ; <-- prevents org default behaviour +;; org-ctags-fail-silently)) ; <-- prevents org default behavior ;; ;; ;; Usage diff --git a/lisp/org-docview.el b/lisp/org-docview.el index d2db685..479f4ff 100644 --- a/lisp/org-docview.el +++ b/lisp/org-docview.el @@ -1,6 +1,6 @@ ;;; org-docview.el --- support for links to doc-view-mode buffers -;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Author: Jan Böcker <jan.boecker at jboecker dot de> ;; Keywords: outlines, hypermedia, calendar, wp @@ -54,8 +54,8 @@ (defun org-docview-export (link description format) "Export a docview link from Org files." - (let* ((path (when (string-match "\\(.+\\)::.+" link) - (match-string 1 link))) + (let* ((path (if (string-match "\\(.+\\)::.+" link) (match-string 1 link) + link)) (desc (or description link))) (when (stringp path) (setq path (org-link-escape (expand-file-name path))) @@ -66,13 +66,14 @@ (t path))))) (defun org-docview-open (link) - (when (string-match "\\(.*\\)::\\([0-9]+\\)$" link) - (let* ((path (match-string 1 link)) - (page (string-to-number (match-string 2 link)))) - (org-open-file path 1) ;; let org-mode open the file (in-emacs = 1) - ;; to ensure org-link-frame-setup is respected - (doc-view-goto-page page) - ))) + (string-match "\\(.*?\\)\\(?:::\\([0-9]+\\)\\)?$" link) + (let ((path (match-string 1 link)) + (page (and (match-beginning 2) + (string-to-number (match-string 2 link))))) + ;; Let Org mode open the file (in-emacs = 1) to ensure + ;; org-link-frame-setup is respected. + (org-open-file path 1) + (when page (doc-view-goto-page page)))) (defun org-docview-store-link () "Store a link to a docview buffer." diff --git a/lisp/org-element.el b/lisp/org-element.el index eb8ff41..c7e76e8 100644 --- a/lisp/org-element.el +++ b/lisp/org-element.el @@ -1,6 +1,6 @@ ;;; org-element.el --- Parser And Applications for Org syntax -;; Copyright (C) 2012-2014 Free Software Foundation, Inc. +;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ;; Author: Nicolas Goaziou <n.goaziou at gmail dot com> ;; Keywords: outlines, hypermedia, calendar, wp @@ -31,7 +31,7 @@ ;; ;; An element always starts and ends at the beginning of a line. With ;; a few exceptions (`clock', `headline', `inlinetask', `item', -;; `planning', `node-property', `quote-section' `section' and +;; `planning', `property-drawer', `node-property', `section' and ;; `table-row' types), it can also accept a fixed set of keywords as ;; attributes. Those are called "affiliated keywords" to distinguish ;; them from other keywords, which are full-fledged elements. Almost @@ -48,10 +48,9 @@ ;; Other element types are: `babel-call', `clock', `comment', ;; `comment-block', `diary-sexp', `example-block', `export-block', ;; `fixed-width', `horizontal-rule', `keyword', `latex-environment', -;; `node-property', `paragraph', `planning', `quote-section', -;; `src-block', `table', `table-row' and `verse-block'. Among them, -;; `paragraph' and `verse-block' types can contain Org objects and -;; plain text. +;; `node-property', `paragraph', `planning', `src-block', `table', +;; `table-row' and `verse-block'. Among them, `paragraph' and +;; `verse-block' types can contain Org objects and plain text. ;; ;; Objects are related to document's contents. Some of them are ;; recursive. Associated types are of the following: `bold', `code', @@ -75,9 +74,9 @@ ;; refers to the element or object containing it. Greater elements, ;; elements and objects containing objects will also have ;; `:contents-begin' and `:contents-end' properties to delimit -;; contents. Eventually, greater elements and elements accepting -;; affiliated keywords will have a `:post-affiliated' property, -;; referring to the buffer position after all such keywords. +;; contents. Eventually, All elements have a `:post-affiliated' +;; property referring to the buffer position after all affiliated +;; keywords, if any, or to their beginning position otherwise. ;; ;; At the lowest level, a `:parent' property is also attached to any ;; string, as a text property. @@ -111,13 +110,15 @@ ;; ;; The library ends by furnishing `org-element-at-point' function, and ;; a way to give information about document structure around point -;; with `org-element-context'. +;; with `org-element-context'. A cache mechanism is also provided for +;; these functions. ;;; Code: (eval-when-compile (require 'cl)) (require 'org) +(require 'avl-tree) @@ -127,56 +128,111 @@ ;; along with the affiliated keywords recognized. Also set up ;; restrictions on recursive objects combinations. ;; -;; These variables really act as a control center for the parsing -;; process. - -(defconst org-element-paragraph-separate - (concat "^\\(?:" - ;; Headlines, inlinetasks. - org-outline-regexp "\\|" - ;; Footnote definitions. - "\\[\\(?:[0-9]+\\|fn:[-_[:word:]]+\\)\\]" "\\|" - ;; Diary sexps. - "%%(" "\\|" - "[ \t]*\\(?:" - ;; Empty lines. - "$" "\\|" - ;; Tables (any type). - "\\(?:|\\|\\+-[-+]\\)" "\\|" - ;; Blocks (any type), Babel calls and keywords. Note: this - ;; is only an indication and need some thorough check. - "#\\(?:[+ ]\\|$\\)" "\\|" - ;; Drawers (any type) and fixed-width areas. This is also - ;; only an indication. - ":" "\\|" - ;; Horizontal rules. - "-\\{5,\\}[ \t]*$" "\\|" - ;; LaTeX environments. - "\\\\begin{\\([A-Za-z0-9]+\\*?\\)}" "\\|" - ;; Planning and Clock lines. - (regexp-opt (list org-scheduled-string - org-deadline-string - org-closed-string - org-clock-string)) - "\\|" - ;; Lists. - (let ((term (case org-plain-list-ordered-item-terminator - (?\) ")") (?. "\\.") (otherwise "[.)]"))) - (alpha (and org-list-allow-alphabetical "\\|[A-Za-z]"))) - (concat "\\(?:[-+*]\\|\\(?:[0-9]+" alpha "\\)" term "\\)" - "\\(?:[ \t]\\|$\\)")) - "\\)\\)") +;; `org-element-update-syntax' builds proper syntax regexps according +;; to current setup. + +(defvar org-element-paragraph-separate nil "Regexp to separate paragraphs in an Org buffer. In the case of lines starting with \"#\" and \":\", this regexp is not sufficient to know if point is at a paragraph ending. See `org-element-paragraph-parser' for more information.") +(defvar org-element--object-regexp nil + "Regexp possibly matching the beginning of an object. +This regexp allows false positives. Dedicated parser (e.g., +`org-export-bold-parser') will take care of further filtering. +Radio links are not matched by this regexp, as they are treated +specially in `org-element--object-lex'.") + +(defun org-element--set-regexps () + "Build variable syntax regexps." + (setq org-element-paragraph-separate + (concat "^\\(?:" + ;; Headlines, inlinetasks. + org-outline-regexp "\\|" + ;; Footnote definitions. + "\\[\\(?:[0-9]+\\|fn:[-_[:word:]]+\\)\\]" "\\|" + ;; Diary sexps. + "%%(" "\\|" + "[ \t]*\\(?:" + ;; Empty lines. + "$" "\\|" + ;; Tables (any type). + "|" "\\|" + "\\+\\(?:-+\\+\\)+[ \t]*$" "\\|" + ;; Comments, keyword-like or block-like constructs. + ;; Blocks and keywords with dual values need to be + ;; double-checked. + "#\\(?: \\|$\\|\\+\\(?:" + "BEGIN_\\S-+" "\\|" + "\\S-+\\(?:\\[.*\\]\\)?:[ \t]*\\)\\)" + "\\|" + ;; Drawers (any type) and fixed-width areas. Drawers + ;; need to be double-checked. + ":\\(?: \\|$\\|[-_[:word:]]+:[ \t]*$\\)" "\\|" + ;; Horizontal rules. + "-\\{5,\\}[ \t]*$" "\\|" + ;; LaTeX environments. + "\\\\begin{\\([A-Za-z0-9*]+\\)}" "\\|" + ;; Clock lines. + (regexp-quote org-clock-string) "\\|" + ;; Lists. + (let ((term (case org-plain-list-ordered-item-terminator + (?\) ")") (?. "\\.") (otherwise "[.)]"))) + (alpha (and org-list-allow-alphabetical "\\|[A-Za-z]"))) + (concat "\\(?:[-+*]\\|\\(?:[0-9]+" alpha "\\)" term "\\)" + "\\(?:[ \t]\\|$\\)")) + "\\)\\)") + org-element--object-regexp + (mapconcat #'identity + (let ((link-types (regexp-opt org-link-types))) + (list + ;; Sub/superscript. + "\\(?:[_^][-{(*+.,[:alnum:]]\\)" + ;; Bold, code, italic, strike-through, underline + ;; and verbatim. + (concat "[*~=+_/]" + (format "[^%s]" + (nth 2 org-emphasis-regexp-components))) + ;; Plain links. + (concat "\\<" link-types ":") + ;; Objects starting with "[": regular link, + ;; footnote reference, statistics cookie, + ;; timestamp (inactive). + "\\[\\(?:fn:\\|\\(?:[0-9]\\|\\(?:%\\|/[0-9]*\\)\\]\\)\\|\\[\\)" + ;; Objects starting with "@": export snippets. + "@@" + ;; Objects starting with "{": macro. + "{{{" + ;; Objects starting with "<" : timestamp + ;; (active, diary), target, radio target and + ;; angular links. + (concat "<\\(?:%%\\|<\\|[0-9]\\|" link-types "\\)") + ;; Objects starting with "$": latex fragment. + "\\$" + ;; Objects starting with "\": line break, + ;; entity, latex fragment. + "\\\\\\(?:[a-zA-Z[(]\\|\\\\[ \t]*$\\|_ +\\)" + ;; Objects starting with raw text: inline Babel + ;; source block, inline Babel call. + "\\(?:call\\|src\\)_")) + "\\|"))) + +(org-element--set-regexps) + +;;;###autoload +(defun org-element-update-syntax () + "Update parser internals." + (interactive) + (org-element--set-regexps) + (org-element-cache-reset 'all)) + (defconst org-element-all-elements '(babel-call center-block clock comment comment-block diary-sexp drawer dynamic-block example-block export-block fixed-width footnote-definition headline horizontal-rule inlinetask item keyword latex-environment node-property paragraph plain-list - planning property-drawer quote-block quote-section section + planning property-drawer quote-block section special-block src-block table table-row verse-block) "Complete list of element types.") @@ -186,23 +242,6 @@ is not sufficient to know if point is at a paragraph ending. See special-block table) "List of recursive element types aka Greater Elements.") -(defconst org-element-all-successors - '(link export-snippet footnote-reference inline-babel-call - inline-src-block latex-or-entity line-break macro plain-link - radio-target statistics-cookie sub/superscript table-cell target - text-markup timestamp) - "Complete list of successors.") - -(defconst org-element-object-successor-alist - '((subscript . sub/superscript) (superscript . sub/superscript) - (bold . text-markup) (code . text-markup) (italic . text-markup) - (strike-through . text-markup) (underline . text-markup) - (verbatim . text-markup) (entity . latex-or-entity) - (latex-fragment . latex-or-entity)) - "Alist of translations between object type and successor name. -Sharing the same successor comes handy when, for example, the -regexp matching one object can also match the other object.") - (defconst org-element-all-objects '(bold code entity export-snippet footnote-reference inline-babel-call inline-src-block italic line-break latex-fragment link macro @@ -211,10 +250,14 @@ regexp matching one object can also match the other object.") "Complete list of object types.") (defconst org-element-recursive-objects - '(bold italic link subscript radio-target strike-through superscript - table-cell underline) + '(bold footnote-reference italic link subscript radio-target strike-through + superscript table-cell underline) "List of recursive object types.") +(defconst org-element-object-containers + (append org-element-recursive-objects '(paragraph table-row verse-block)) + "List of object or element types that can directly contain objects.") + (defvar org-element-block-name-alist '(("CENTER" . org-element-center-block-parser) ("COMMENT" . org-element-comment-block-parser) @@ -226,12 +269,6 @@ regexp matching one object can also match the other object.") Names must be uppercase. Any block whose name has no association is parsed with `org-element-special-block-parser'.") -(defconst org-element-link-type-is-file - '("file" "file+emacs" "file+sys" "docview") - "List of link types equivalent to \"file\". -Only these types can accept search options and an explicit -application to open them.") - (defconst org-element-affiliated-keywords '("CAPTION" "DATA" "HEADER" "HEADERS" "LABEL" "NAME" "PLOT" "RESNAME" "RESULT" "RESULTS" "SOURCE" "SRCNAME" "TBLNAME") @@ -268,6 +305,13 @@ strings and objects. This list is checked after translations have been applied. See `org-element-keyword-translation-alist'.") +(defconst org-element--parsed-properties-alist + (mapcar (lambda (k) (cons k (intern (concat ":" (downcase k))))) + org-element-parsed-keywords) + "Alist of parsed keywords and associated properties. +This is generated from `org-element-parsed-keywords', which +see.") + (defconst org-element-dual-keywords '("CAPTION" "RESULTS") "List of affiliated keywords which can have a secondary value. @@ -280,13 +324,8 @@ associated to a hash value with the following: This list is checked after translations have been applied. See `org-element-keyword-translation-alist'.") -(defconst org-element-document-properties '("AUTHOR" "DATE" "TITLE") - "List of properties associated to the whole document. -Any keyword in this list will have its value parsed and stored as -a secondary string.") - (defconst org-element--affiliated-re - (format "[ \t]*#\\+\\(?:%s\\):\\(?: \\|$\\)" + (format "[ \t]*#\\+\\(?:%s\\):[ \t]*" (concat ;; Dual affiliated keywords. (format "\\(?1:%s\\)\\(?:\\[\\(.*\\)\\]\\)?" @@ -296,8 +335,7 @@ a secondary string.") (format "\\(?1:%s\\)" (regexp-opt (org-remove-if - #'(lambda (keyword) - (member keyword org-element-dual-keywords)) + (lambda (k) (member k org-element-dual-keywords)) org-element-affiliated-keywords))) "\\|" ;; Export attributes. @@ -311,8 +349,7 @@ match group 2. Don't modify it, set `org-element-affiliated-keywords' instead.") (defconst org-element-object-restrictions - (let* ((standard-set - (remq 'plain-link (remq 'table-cell org-element-all-successors))) + (let* ((standard-set (remq 'table-cell org-element-all-objects)) (standard-set-no-line-break (remq 'line-break standard-set))) `((bold ,@standard-set) (footnote-reference ,@standard-set) @@ -320,30 +357,33 @@ Don't modify it, set `org-element-affiliated-keywords' instead.") (inlinetask ,@standard-set-no-line-break) (italic ,@standard-set) (item ,@standard-set-no-line-break) - (keyword ,@standard-set) + (keyword ,@(remq 'footnote-reference standard-set)) ;; Ignore all links excepted plain links in a link description. ;; Also ignore radio-targets and line breaks. - (link export-snippet inline-babel-call inline-src-block latex-or-entity - macro plain-link statistics-cookie sub/superscript text-markup) + (link bold code entity export-snippet inline-babel-call inline-src-block + italic latex-fragment macro plain-link statistics-cookie + strike-through subscript superscript underline verbatim) (paragraph ,@standard-set) ;; Remove any variable object from radio target as it would ;; prevent it from being properly recognized. - (radio-target latex-or-entity sub/superscript text-markup) + (radio-target bold code entity italic latex-fragment strike-through + subscript superscript underline superscript) (strike-through ,@standard-set) (subscript ,@standard-set) (superscript ,@standard-set) ;; Ignore inline babel call and inline src block as formulas are ;; possible. Also ignore line breaks and statistics cookies. - (table-cell link export-snippet footnote-reference latex-or-entity macro - radio-target sub/superscript target text-markup timestamp) + (table-cell bold code entity export-snippet footnote-reference italic + latex-fragment link macro radio-target strike-through + subscript superscript target timestamp underline verbatim) (table-row table-cell) (underline ,@standard-set) (verse-block ,@standard-set))) "Alist of objects restrictions. -CAR is an element or object type containing objects and CDR is -a list of successors that will be called within an element or -object of such type. +key is an element or object type containing objects and value is +a list of types that can be contained within an element or object +of such type. For example, in a `radio-target' object, one can only find entities, latex-fragments, subscript, superscript and text @@ -354,11 +394,19 @@ This alist also applies to secondary string. For example, an still has an entry since one of its properties (`:title') does.") (defconst org-element-secondary-value-alist - '((headline . :title) - (inlinetask . :title) - (item . :tag) - (footnote-reference . :inline-definition)) - "Alist between element types and location of secondary value.") + '((headline :title) + (inlinetask :title) + (item :tag)) + "Alist between element types and locations of secondary values.") + +(defconst org-element--pair-square-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) + (dolist (char '(?\{ ?\} ?\( ?\) ?\< ?\>) table) + (modify-syntax-entry char " " table))) + "Table used internally to pair only square brackets. +Other brackets are treated as spaces.") @@ -368,10 +416,16 @@ still has an entry since one of its properties (`:title') does.") ;; `org-element-contents' and `org-element-restriction'. ;; ;; Setter functions allow to modify elements by side effect. There is -;; `org-element-put-property', `org-element-set-contents', -;; `org-element-set-element' and `org-element-adopt-element'. Note -;; that `org-element-set-element' and `org-element-adopt-elements' are -;; higher level functions since also update `:parent' property. +;; `org-element-put-property', `org-element-set-contents'. These +;; low-level functions are useful to build a parse tree. +;; +;; `org-element-adopt-element', `org-element-set-element', +;; `org-element-extract-element' and `org-element-insert-before' are +;; high-level functions useful to modify a parse tree. +;; +;; `org-element-secondary-p' is a predicate used to know if a given +;; object belongs to a secondary string. `org-element-copy' returns +;; an element or object, stripping its parent property in the process. (defsubst org-element-type (element) "Return type of ELEMENT. @@ -411,29 +465,22 @@ Return modified element." element)) (defsubst org-element-set-contents (element &rest contents) - "Set ELEMENT contents to CONTENTS. -Return modified element." + "Set ELEMENT contents to CONTENTS." (cond ((not element) (list contents)) ((not (symbolp (car element))) contents) ((cdr element) (setcdr (cdr element) contents)) (t (nconc element contents)))) -(defsubst org-element-set-element (old new) - "Replace element or object OLD with element or object NEW. -The function takes care of setting `:parent' property for NEW." - ;; Since OLD is going to be changed into NEW by side-effect, first - ;; make sure that every element or object within NEW has OLD as - ;; parent. - (mapc (lambda (blob) (org-element-put-property blob :parent old)) - (org-element-contents new)) - ;; Transfer contents. - (apply 'org-element-set-contents old (org-element-contents new)) - ;; Ensure NEW has same parent as OLD, then overwrite OLD properties - ;; with NEW's. - (org-element-put-property new :parent (org-element-property :parent old)) - (setcar (cdr old) (nth 1 new)) - ;; Transfer type. - (setcar old (car new))) +(defun org-element-secondary-p (object) + "Non-nil when OBJECT directly belongs to a secondary string. +Return value is the property name, as a keyword, or nil." + (let* ((parent (org-element-property :parent object)) + (properties (cdr (assq (org-element-type parent) + org-element-secondary-value-alist)))) + (catch 'exit + (dolist (p properties) + (and (memq object (org-element-property p parent)) + (throw 'exit p)))))) (defsubst org-element-adopt-elements (parent &rest children) "Append elements to the contents of another element. @@ -443,18 +490,109 @@ objects, or a strings. The function takes care of setting `:parent' property for CHILD. Return parent element." - ;; Link every child to PARENT. If PARENT is nil, it is a secondary - ;; string: parent is the list itself. - (mapc (lambda (child) - (org-element-put-property child :parent (or parent children))) - children) - ;; Add CHILDREN at the end of PARENT contents. - (when parent - (apply 'org-element-set-contents - parent - (nconc (org-element-contents parent) children))) - ;; Return modified PARENT element. - (or parent children)) + (if (not children) parent + ;; Link every child to PARENT. If PARENT is nil, it is a secondary + ;; string: parent is the list itself. + (dolist (child children) + (org-element-put-property child :parent (or parent children))) + ;; Add CHILDREN at the end of PARENT contents. + (when parent + (apply #'org-element-set-contents + parent + (nconc (org-element-contents parent) children))) + ;; Return modified PARENT element. + (or parent children))) + +(defun org-element-extract-element (element) + "Extract ELEMENT from parse tree. +Remove element from the parse tree by side-effect, and return it +with its `:parent' property stripped out." + (let ((parent (org-element-property :parent element)) + (secondary (org-element-secondary-p element))) + (if secondary + (org-element-put-property + parent secondary + (delq element (org-element-property secondary parent))) + (apply #'org-element-set-contents + parent + (delq element (org-element-contents parent)))) + ;; Return ELEMENT with its :parent removed. + (org-element-put-property element :parent nil))) + +(defun org-element-insert-before (element location) + "Insert ELEMENT before LOCATION in parse tree. +LOCATION is an element, object or string within the parse tree. +Parse tree is modified by side effect." + (let* ((parent (org-element-property :parent location)) + (property (org-element-secondary-p location)) + (siblings (if property (org-element-property property parent) + (org-element-contents parent))) + ;; Special case: LOCATION is the first element of an + ;; independent secondary string (e.g. :title property). Add + ;; ELEMENT in-place. + (specialp (and (not property) + (eq siblings parent) + (eq (car parent) location)))) + ;; Install ELEMENT at the appropriate POSITION within SIBLINGS. + (cond (specialp) + ((or (null siblings) (eq (car siblings) location)) + (push element siblings)) + ((null location) (nconc siblings (list element))) + (t (let ((previous (cadr (memq location (reverse siblings))))) + (if (not previous) + (error "No location found to insert element") + (let ((next (memq previous siblings))) + (setcdr next (cons element (cdr next)))))))) + ;; Store SIBLINGS at appropriate place in parse tree. + (cond + (specialp (setcdr parent (copy-sequence parent)) (setcar parent element)) + (property (org-element-put-property parent property siblings)) + (t (apply #'org-element-set-contents parent siblings))) + ;; Set appropriate :parent property. + (org-element-put-property element :parent parent))) + +(defun org-element-set-element (old new) + "Replace element or object OLD with element or object NEW. +The function takes care of setting `:parent' property for NEW." + ;; Ensure OLD and NEW have the same parent. + (org-element-put-property new :parent (org-element-property :parent old)) + (if (or (memq (org-element-type old) '(plain-text nil)) + (memq (org-element-type new) '(plain-text nil))) + ;; We cannot replace OLD with NEW since one of them is not an + ;; object or element. We take the long path. + (progn (org-element-insert-before new old) + (org-element-extract-element old)) + ;; Since OLD is going to be changed into NEW by side-effect, first + ;; make sure that every element or object within NEW has OLD as + ;; parent. + (dolist (blob (org-element-contents new)) + (org-element-put-property blob :parent old)) + ;; Transfer contents. + (apply #'org-element-set-contents old (org-element-contents new)) + ;; Overwrite OLD's properties with NEW's. + (setcar (cdr old) (nth 1 new)) + ;; Transfer type. + (setcar old (car new)))) + +(defun org-element-create (type &optional props &rest children) + "Create a new element of type TYPE. +Optional argument PROPS, when non-nil, is a plist defining the +properties of the element. CHILDREN can be elements, objects or +strings." + (apply #'org-element-adopt-elements (list type props) children)) + +(defun org-element-copy (datum) + "Return a copy of DATUM. +DATUM is an element, object, string or nil. `:parent' property +is cleared and contents are removed in the process." + (when datum + (let ((type (org-element-type datum))) + (case type + (org-data (list 'org-data nil)) + (plain-text (substring-no-properties datum)) + ((nil) (copy-sequence datum)) + (otherwise + (list type (plist-put (copy-sequence (nth 1 datum)) :parent nil))))))) @@ -467,7 +605,7 @@ Return parent element." ;; Most of them accepts no argument. Though, exceptions exist. Hence ;; every element containing a secondary string (see ;; `org-element-secondary-value-alist') will accept an optional -;; argument to toggle parsing of that secondary string. Moreover, +;; argument to toggle parsing of these secondary strings. Moreover, ;; `item' parser requires current list's structure as its first ;; element. ;; @@ -503,8 +641,8 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `center-block' and CDR is a plist -containing `:begin', `:end', `:hiddenp', `:contents-begin', -`:contents-end', `:post-blank' and `:post-affiliated' keywords. +containing `:begin', `:end', `:contents-begin', `:contents-end', +`:post-blank' and `:post-affiliated' keywords. Assume point is at the beginning of the block." (let ((case-fold-search t)) @@ -520,7 +658,6 @@ Assume point is at the beginning of the block." (and (< (point) block-end-line) (point)))) (contents-end (and contents-begin block-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char block-end-line) (forward-line) (point))) @@ -531,7 +668,6 @@ Assume point is at the beginning of the block." (nconc (list :begin begin :end end - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -555,7 +691,7 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `drawer' and CDR is a plist containing -`:drawer-name', `:begin', `:end', `:hiddenp', `:contents-begin', +`:drawer-name', `:begin', `:end', `:contents-begin', `:contents-end', `:post-blank' and `:post-affiliated' keywords. Assume point is at beginning of drawer." @@ -574,7 +710,6 @@ Assume point is at beginning of drawer." (and (< (point) drawer-end-line) (point)))) (contents-end (and contents-begin drawer-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char drawer-end-line) (forward-line) (point))) @@ -585,7 +720,6 @@ Assume point is at beginning of drawer." (list :begin begin :end end :drawer-name name - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -611,9 +745,9 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `dynamic-block' and CDR is a plist -containing `:block-name', `:begin', `:end', `:hiddenp', -`:contents-begin', `:contents-end', `:arguments', `:post-blank' -and `:post-affiliated' keywords. +containing `:block-name', `:begin', `:end', `:contents-begin', +`:contents-end', `:arguments', `:post-blank' and +`:post-affiliated' keywords. Assume point is at beginning of dynamic block." (let ((case-fold-search t)) @@ -633,7 +767,6 @@ Assume point is at beginning of dynamic block." (and (< (point) block-end-line) (point)))) (contents-end (and contents-begin block-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char block-end-line) (forward-line) (point))) @@ -645,7 +778,6 @@ Assume point is at beginning of dynamic block." :end end :block-name name :arguments arguments - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -722,16 +854,52 @@ CONTENTS is the contents of the footnote-definition." ;;;; Headline +(defun org-element--get-node-properties () + "Return node properties associated to headline at point. +Upcase property names. It avoids confusion between properties +obtained through property drawer and default properties from the +parser (e.g. `:end' and :END:). Return value is a plist." + (save-excursion + (forward-line) + (when (org-looking-at-p org-planning-line-re) (forward-line)) + (when (looking-at org-property-drawer-re) + (forward-line) + (let ((end (match-end 0)) properties) + (while (< (line-end-position) end) + (looking-at org-property-re) + (push (org-match-string-no-properties 3) properties) + (push (intern (concat ":" (upcase (match-string 2)))) properties) + (forward-line)) + properties)))) + +(defun org-element--get-time-properties () + "Return time properties associated to headline at point. +Return value is a plist." + (save-excursion + (when (progn (forward-line) (looking-at org-planning-line-re)) + (let ((end (line-end-position)) plist) + (while (re-search-forward org-keyword-time-not-clock-regexp end t) + (goto-char (match-end 1)) + (skip-chars-forward " \t") + (let ((keyword (match-string 1)) + (time (org-element-timestamp-parser))) + (cond ((equal keyword org-scheduled-string) + (setq plist (plist-put plist :scheduled time))) + ((equal keyword org-deadline-string) + (setq plist (plist-put plist :deadline time))) + (t (setq plist (plist-put plist :closed time)))))) + plist)))) + (defun org-element-headline-parser (limit &optional raw-secondary-p) "Parse a headline. Return a list whose CAR is `headline' and CDR is a plist -containing `:raw-value', `:title', `:alt-title', `:begin', -`:end', `:pre-blank', `:hiddenp', `:contents-begin', -`:contents-end', `:level', `:priority', `:tags', -`:todo-keyword',`:todo-type', `:scheduled', `:deadline', -`:closed', `:quotedp', `:archivedp', `:commentedp', -`:footnote-section-p' and `:post-blank' keywords. +containing `:raw-value', `:title', `:begin', `:end', +`:pre-blank', `:contents-begin' and `:contents-end', `:level', +`:priority', `:tags', `:todo-keyword',`:todo-type', `:scheduled', +`:deadline', `:closed', `:archivedp', `:commentedp' +`:footnote-section-p', `:post-blank' and `:post-affiliated' +keywords. The plist also contains any property set in the property drawer, with its name in upper cases and colons added at the @@ -744,80 +912,47 @@ parsed as a secondary string, but as a plain string instead. Assume point is at beginning of the headline." (save-excursion - (let* ((components (org-heading-components)) - (level (nth 1 components)) - (todo (nth 2 components)) + (let* ((begin (point)) + (level (prog1 (org-reduced-level (skip-chars-forward "*")) + (skip-chars-forward " \t"))) + (todo (and org-todo-regexp + (let (case-fold-search) (looking-at org-todo-regexp)) + (progn (goto-char (match-end 0)) + (skip-chars-forward " \t") + (match-string 0)))) (todo-type (and todo (if (member todo org-done-keywords) 'done 'todo))) - (tags (let ((raw-tags (nth 5 components))) - (and raw-tags (org-split-string raw-tags ":")))) - (raw-value (or (nth 4 components) "")) - (quotedp - (let ((case-fold-search nil)) - (string-match (format "^%s\\( \\|$\\)" org-quote-string) - raw-value))) + (priority (and (looking-at "\\[#.\\][ \t]*") + (progn (goto-char (match-end 0)) + (aref (match-string 0) 2)))) (commentedp - (let ((case-fold-search nil)) - (string-match (format "^%s\\( \\|$\\)" org-comment-string) - raw-value))) + (and (let (case-fold-search) (looking-at org-comment-string)) + (goto-char (match-end 0)))) + (title-start (point)) + (tags (when (re-search-forward + (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") + (line-end-position) + 'move) + (goto-char (match-beginning 0)) + (org-split-string (match-string 1) ":"))) + (title-end (point)) + (raw-value (org-trim + (buffer-substring-no-properties title-start title-end))) (archivedp (member org-archive-tag tags)) (footnote-section-p (and org-footnote-section (string= org-footnote-section raw-value))) - ;; Upcase property names. It avoids confusion between - ;; properties obtained through property drawer and default - ;; properties from the parser (e.g. `:end' and :END:) - (standard-props - (let (plist) - (mapc - (lambda (p) - (setq plist - (plist-put plist - (intern (concat ":" (upcase (car p)))) - (cdr p)))) - (org-entry-properties nil 'standard)) - plist)) - (time-props - ;; Read time properties on the line below the headline. - (save-excursion - (when (progn (forward-line) - (looking-at org-planning-or-clock-line-re)) - (let ((end (line-end-position)) plist) - (while (re-search-forward - org-keyword-time-not-clock-regexp end t) - (goto-char (match-end 1)) - (skip-chars-forward " \t") - (let ((keyword (match-string 1)) - (time (org-element-timestamp-parser))) - (cond ((equal keyword org-scheduled-string) - (setq plist (plist-put plist :scheduled time))) - ((equal keyword org-deadline-string) - (setq plist (plist-put plist :deadline time))) - (t (setq plist (plist-put plist :closed time)))))) - plist)))) - (begin (point)) + (standard-props (org-element--get-node-properties)) + (time-props (org-element--get-time-properties)) (end (min (save-excursion (org-end-of-subtree t t)) limit)) (pos-after-head (progn (forward-line) (point))) (contents-begin (save-excursion (skip-chars-forward " \r\t\n" end) (and (/= (point) end) (line-beginning-position)))) - (hidden (org-invisible-p2)) (contents-end (and contents-begin (progn (goto-char end) (skip-chars-backward " \r\t\n") (forward-line) (point))))) - ;; Clean RAW-VALUE from any quote or comment string. - (when (or quotedp commentedp) - (let ((case-fold-search nil)) - (setq raw-value - (replace-regexp-in-string - (concat - (regexp-opt (list org-quote-string org-comment-string)) - "\\(?: \\|$\\)") - "" - raw-value)))) - ;; Clean TAGS from archive tag, if any. - (when archivedp (setq tags (delete org-archive-tag tags))) (let ((headline (list 'headline (nconc @@ -827,11 +962,10 @@ Assume point is at beginning of the headline." :pre-blank (if (not contents-begin) 0 (count-lines pos-after-head contents-begin)) - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :level level - :priority (nth 3 components) + :priority priority :tags tags :todo-keyword todo :todo-type todo-type @@ -841,21 +975,23 @@ Assume point is at beginning of the headline." :footnote-section-p footnote-section-p :archivedp archivedp :commentedp commentedp - :quotedp quotedp) + :post-affiliated begin) time-props standard-props)))) - (let ((alt-title (org-element-property :ALT_TITLE headline))) - (when alt-title - (org-element-put-property - headline :alt-title - (if raw-secondary-p alt-title - (org-element-parse-secondary-string - alt-title (org-element-restriction 'headline) headline))))) (org-element-put-property headline :title (if raw-secondary-p raw-value - (org-element-parse-secondary-string - raw-value (org-element-restriction 'headline) headline))))))) + (let ((title (org-element--parse-objects + (progn (goto-char title-start) + (skip-chars-forward " \t") + (point)) + (progn (goto-char title-end) + (skip-chars-backward " \t") + (point)) + nil + (org-element-restriction 'headline)))) + (dolist (datum title title) + (org-element-put-property datum :parent headline))))))))) (defun org-element-headline-interpreter (headline contents) "Interpret HEADLINE element as Org syntax. @@ -865,22 +1001,17 @@ CONTENTS is the contents of the element." (priority (org-element-property :priority headline)) (title (org-element-interpret-data (org-element-property :title headline))) - (tags (let ((tag-list (if (org-element-property :archivedp headline) - (cons org-archive-tag - (org-element-property :tags headline)) - (org-element-property :tags headline)))) + (tags (let ((tag-list (org-element-property :tags headline))) (and tag-list (format ":%s:" (mapconcat #'identity tag-list ":"))))) (commentedp (org-element-property :commentedp headline)) - (quotedp (org-element-property :quotedp headline)) (pre-blank (or (org-element-property :pre-blank headline) 0)) (heading (concat (make-string (if org-odd-levels-only (1- (* level 2)) level) ?*) (and todo (concat " " todo)) - (and quotedp (concat " " org-quote-string)) (and commentedp (concat " " org-comment-string)) - (and priority (format " [#%s]" (char-to-string priority))) + (and priority (format " [#%c]" priority)) " " (if (and org-footnote-section (org-element-property :footnote-section-p headline)) @@ -912,10 +1043,10 @@ CONTENTS is the contents of the element." "Parse an inline task. Return a list whose CAR is `inlinetask' and CDR is a plist -containing `:title', `:begin', `:end', `:hiddenp', -`:contents-begin' and `:contents-end', `:level', `:priority', -`:raw-value', `:tags', `:todo-keyword', `:todo-type', -`:scheduled', `:deadline', `:closed' and `:post-blank' keywords. +containing `:title', `:begin', `:end', `:contents-begin' and +`:contents-end', `:level', `:priority', `:raw-value', `:tags', +`:todo-keyword', `:todo-type', `:scheduled', `:deadline', +`:closed', `:post-blank' and `:post-affiliated' keywords. The plist also contains any property set in the property drawer, with its name in upper cases and colons added at the @@ -928,53 +1059,37 @@ string instead. Assume point is at beginning of the inline task." (save-excursion (let* ((begin (point)) - (components (org-heading-components)) - (todo (nth 2 components)) + (level (prog1 (org-reduced-level (skip-chars-forward "*")) + (skip-chars-forward " \t"))) + (todo (and org-todo-regexp + (let (case-fold-search) (looking-at org-todo-regexp)) + (progn (goto-char (match-end 0)) + (skip-chars-forward " \t") + (match-string 0)))) (todo-type (and todo (if (member todo org-done-keywords) 'done 'todo))) - (tags (let ((raw-tags (nth 5 components))) - (and raw-tags (org-split-string raw-tags ":")))) - (raw-value (or (nth 4 components) "")) - ;; Upcase property names. It avoids confusion between - ;; properties obtained through property drawer and default - ;; properties from the parser (e.g. `:end' and :END:) - (standard-props - (let (plist) - (mapc - (lambda (p) - (setq plist - (plist-put plist - (intern (concat ":" (upcase (car p)))) - (cdr p)))) - (org-entry-properties nil 'standard)) - plist)) - (time-props - ;; Read time properties on the line below the inlinetask - ;; opening string. - (save-excursion - (when (progn (forward-line) - (looking-at org-planning-or-clock-line-re)) - (let ((end (line-end-position)) plist) - (while (re-search-forward - org-keyword-time-not-clock-regexp end t) - (goto-char (match-end 1)) - (skip-chars-forward " \t") - (let ((keyword (match-string 1)) - (time (org-element-timestamp-parser))) - (cond ((equal keyword org-scheduled-string) - (setq plist (plist-put plist :scheduled time))) - ((equal keyword org-deadline-string) - (setq plist (plist-put plist :deadline time))) - (t (setq plist (plist-put plist :closed time)))))) - plist)))) + (priority (and (looking-at "\\[#.\\][ \t]*") + (progn (goto-char (match-end 0)) + (aref (match-string 0) 2)))) + (title-start (point)) + (tags (when (re-search-forward + (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") + (line-end-position) + 'move) + (goto-char (match-beginning 0)) + (org-split-string (match-string 1) ":"))) + (title-end (point)) + (raw-value (org-trim + (buffer-substring-no-properties title-start title-end))) (task-end (save-excursion (end-of-line) (and (re-search-forward org-outline-regexp-bol limit t) (org-looking-at-p "END[ \t]*$") (line-beginning-position)))) + (standard-props (and task-end (org-element--get-node-properties))) + (time-props (and task-end (org-element--get-time-properties))) (contents-begin (progn (forward-line) (and task-end (< (point) task-end) (point)))) - (hidden (and contents-begin (org-invisible-p2))) (contents-end (and contents-begin task-end)) (before-blank (if (not task-end) (point) (goto-char task-end) @@ -988,24 +1103,31 @@ Assume point is at beginning of the inline task." (list :raw-value raw-value :begin begin :end end - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end - :level (nth 1 components) - :priority (nth 3 components) + :level level + :priority priority :tags tags :todo-keyword todo :todo-type todo-type - :post-blank (count-lines before-blank end)) + :post-blank (count-lines before-blank end) + :post-affiliated begin) time-props standard-props)))) (org-element-put-property inlinetask :title (if raw-secondary-p raw-value - (org-element-parse-secondary-string - raw-value - (org-element-restriction 'inlinetask) - inlinetask)))))) + (let ((title (org-element--parse-objects + (progn (goto-char title-start) + (skip-chars-forward " \t") + (point)) + (progn (goto-char title-end) + (skip-chars-backward " \t") + (point)) + nil + (org-element-restriction 'inlinetask)))) + (dolist (datum title title) + (org-element-put-property datum :parent inlinetask)))))))) (defun org-element-inlinetask-interpreter (inlinetask contents) "Interpret INLINETASK element as Org syntax. @@ -1020,8 +1142,7 @@ CONTENTS is the contents of inlinetask." (format ":%s:" (mapconcat 'identity tag-list ":"))))) (task (concat (make-string level ?*) (and todo (concat " " todo)) - (and priority - (format " [#%s]" (char-to-string priority))) + (and priority (format " [#%c]" priority)) (and title (concat " " title))))) (concat task ;; Align tags. @@ -1055,8 +1176,8 @@ STRUCT is the structure of the plain list. Return a list whose CAR is `item' and CDR is a plist containing `:bullet', `:begin', `:end', `:contents-begin', `:contents-end', -`:checkbox', `:counter', `:tag', `:structure', `:hiddenp' and -`:post-blank' keywords. +`:checkbox', `:counter', `:tag', `:structure', `:post-blank' and +`:post-affiliated' keywords. When optional argument RAW-SECONDARY-P is non-nil, item's tag, if any, will not be parsed as a secondary string, but as a plain @@ -1068,11 +1189,11 @@ Assume point is at the beginning of the item." (looking-at org-list-full-item-re) (let* ((begin (point)) (bullet (org-match-string-no-properties 1)) - (checkbox (let ((box (org-match-string-no-properties 3))) + (checkbox (let ((box (match-string 3))) (cond ((equal "[ ]" box) 'off) ((equal "[X]" box) 'on) ((equal "[-]" box) 'trans)))) - (counter (let ((c (org-match-string-no-properties 2))) + (counter (let ((c (match-string 2))) (save-match-data (cond ((not c) nil) @@ -1081,9 +1202,8 @@ Assume point is at the beginning of the item." 64)) ((string-match "[0-9]+" c) (string-to-number (match-string 0 c))))))) - (end (save-excursion (goto-char (org-list-get-item-end begin struct)) - (unless (bolp) (forward-line)) - (point))) + (end (progn (goto-char (nth 6 (assq (point) struct))) + (if (bolp) (point) (line-beginning-position 2)))) (contents-begin (progn (goto-char ;; Ignore tags in un-ordered lists: they are just @@ -1092,40 +1212,38 @@ Assume point is at the beginning of the item." (save-match-data (string-match "[.)]" bullet))) (match-beginning 4) (match-end 0))) - (skip-chars-forward " \r\t\n" limit) - ;; If first line isn't empty, contents really start - ;; at the text after item's meta-data. - (if (= (point-at-bol) begin) (point) (point-at-bol)))) - (hidden (progn (forward-line) - (and (not (= (point) end)) (org-invisible-p2)))) - (contents-end (progn (goto-char end) - (skip-chars-backward " \r\t\n") - (forward-line) - (point))) + (skip-chars-forward " \r\t\n" end) + (cond ((= (point) end) nil) + ;; If first line isn't empty, contents really + ;; start at the text after item's meta-data. + ((= (line-beginning-position) begin) (point)) + (t (line-beginning-position))))) + (contents-end (and contents-begin + (progn (goto-char end) + (skip-chars-backward " \r\t\n") + (line-beginning-position 2)))) (item (list 'item (list :bullet bullet :begin begin :end end - ;; CONTENTS-BEGIN and CONTENTS-END may be - ;; mixed up in the case of an empty item - ;; separated from the next by a blank line. - ;; Thus ensure the former is always the - ;; smallest. - :contents-begin (min contents-begin contents-end) - :contents-end (max contents-begin contents-end) + :contents-begin contents-begin + :contents-end contents-end :checkbox checkbox :counter counter - :hiddenp hidden :structure struct - :post-blank (count-lines contents-end end))))) + :post-blank (count-lines (or contents-end begin) end) + :post-affiliated begin)))) (org-element-put-property item :tag - (let ((raw-tag (org-list-get-tag begin struct))) - (and raw-tag - (if raw-secondary-p raw-tag - (org-element-parse-secondary-string - raw-tag (org-element-restriction 'item) item)))))))) + (let ((raw (org-list-get-tag begin struct))) + (when raw + (if raw-secondary-p raw + (let ((tag (org-element--parse-objects + (match-beginning 4) (match-end 4) nil + (org-element-restriction 'item)))) + (dolist (datum tag tag) + (org-element-put-property datum :parent item)))))))))) (defun org-element-item-interpreter (item contents) "Interpret ITEM element as Org syntax. @@ -1168,9 +1286,6 @@ CONTENTS is the contents of the element." (let ((case-fold-search t) (top-ind limit) (item-re (org-item-re)) - (drawers-re (concat ":\\(" - (mapconcat 'regexp-quote org-drawers "\\|") - "\\):[ \t]*$")) (inlinetask-re (and (featurep 'org-inlinetask) "^\\*+ ")) items struct) (save-excursion @@ -1226,7 +1341,8 @@ CONTENTS is the contents of the element." (goto-char origin))))) ;; At some text line. Check if it ends any previous item. (t - (let ((ind (progn (skip-chars-forward " \t") (current-column)))) + (let ((ind (save-excursion (skip-chars-forward " \t") + (current-column)))) (when (<= ind top-ind) (skip-chars-backward " \r\t\n") (forward-line)) @@ -1235,15 +1351,14 @@ CONTENTS is the contents of the element." (setcar (nthcdr 6 item) (line-beginning-position)) (push item struct) (unless items - (throw 'exit (sort struct 'car-less-than-car)))))) + (throw 'exit (sort struct #'car-less-than-car)))))) ;; Skip blocks (any type) and drawers contents. (cond - ((and (looking-at "#\\+BEGIN\\(:\\|_\\S-+\\)") + ((and (looking-at "[ \t]*#\\+BEGIN\\(:\\|_\\S-+\\)") (re-search-forward - (format "^[ \t]*#\\+END%s[ \t]*$" - (org-match-string-no-properties 1)) + (format "^[ \t]*#\\+END%s[ \t]*$" (match-string 1)) limit t))) - ((and (looking-at drawers-re) + ((and (looking-at org-drawer-regexp) (re-search-forward "^[ \t]*:END:[ \t]*$" limit t)))) (forward-line)))))))) @@ -1264,15 +1379,20 @@ containing `:type', `:begin', `:end', `:contents-begin' and Assume point is at the beginning of the list." (save-excursion (let* ((struct (or structure (org-element--list-struct limit))) - (prevs (org-list-prevs-alist struct)) - (type (org-list-get-list-type (point) struct prevs)) + (type (cond ((org-looking-at-p "[ \t]*[A-Za-z0-9]") 'ordered) + ((nth 5 (assq (point) struct)) 'descriptive) + (t 'unordered))) (contents-begin (point)) (begin (car affiliated)) - (contents-end - (progn (goto-char (org-list-get-list-end (point) struct prevs)) - (unless (bolp) (forward-line)) - (point))) - (end (progn (skip-chars-forward " \r\t\n" limit) + (contents-end (let* ((item (assq contents-begin struct)) + (ind (nth 1 item)) + (pos (nth 6 item))) + (while (and (setq item (assq pos struct)) + (= (nth 1 item) ind)) + (setq pos (nth 6 item))) + pos)) + (end (progn (goto-char contents-end) + (skip-chars-forward " \r\t\n" limit) (if (= (point) limit) limit (line-beginning-position))))) ;; Return value. (list 'plain-list @@ -1299,49 +1419,33 @@ CONTENTS is the contents of the element." ;;;; Property Drawer -(defun org-element-property-drawer-parser (limit affiliated) +(defun org-element-property-drawer-parser (limit) "Parse a property drawer. -LIMIT bounds the search. AFFILIATED is a list of which CAR is -the buffer position at the beginning of the first affiliated -keyword and CDR is a plist of affiliated keywords along with -their value. +LIMIT bounds the search. -Return a list whose CAR is `property-drawer' and CDR is a plist -containing `:begin', `:end', `:hiddenp', `:contents-begin', -`:contents-end', `:post-blank' and `:post-affiliated' keywords. +Return a list whose car is `property-drawer' and cdr is a plist +containing `:begin', `:end', `:contents-begin', `:contents-end', +`:post-blank' and `:post-affiliated' keywords. Assume point is at the beginning of the property drawer." - (let ((case-fold-search t)) - (if (not (save-excursion (re-search-forward "^[ \t]*:END:[ \t]*$" limit t))) - ;; Incomplete drawer: parse it as a paragraph. - (org-element-paragraph-parser limit affiliated) - (save-excursion - (let* ((drawer-end-line (match-beginning 0)) - (begin (car affiliated)) - (post-affiliated (point)) - (contents-begin - (progn - (forward-line) - (and (re-search-forward org-property-re drawer-end-line t) - (line-beginning-position)))) - (contents-end (and contents-begin drawer-end-line)) - (hidden (org-invisible-p2)) - (pos-before-blank (progn (goto-char drawer-end-line) - (forward-line) - (point))) - (end (progn (skip-chars-forward " \r\t\n" limit) - (if (eobp) (point) (line-beginning-position))))) - (list 'property-drawer - (nconc - (list :begin begin - :end end - :hiddenp hidden - :contents-begin contents-begin - :contents-end contents-end - :post-blank (count-lines pos-before-blank end) - :post-affiliated post-affiliated) - (cdr affiliated)))))))) + (save-excursion + (let ((case-fold-search t) + (begin (point)) + (contents-begin (line-beginning-position 2))) + (re-search-forward "^[ \t]*:END:[ \t]*$" limit t) + (let ((contents-end (and (> (match-beginning 0) contents-begin) + (match-beginning 0))) + (before-blank (progn (forward-line) (point))) + (end (progn (skip-chars-forward " \r\t\n" limit) + (if (eobp) (point) (line-beginning-position))))) + (list 'property-drawer + (list :begin begin + :end end + :contents-begin (and contents-end contents-begin) + :contents-end contents-end + :post-blank (count-lines before-blank end) + :post-affiliated begin)))))) (defun org-element-property-drawer-interpreter (property-drawer contents) "Interpret PROPERTY-DRAWER element as Org syntax. @@ -1360,8 +1464,8 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `quote-block' and CDR is a plist -containing `:begin', `:end', `:hiddenp', `:contents-begin', -`:contents-end', `:post-blank' and `:post-affiliated' keywords. +containing `:begin', `:end', `:contents-begin', `:contents-end', +`:post-blank' and `:post-affiliated' keywords. Assume point is at the beginning of the block." (let ((case-fold-search t)) @@ -1378,7 +1482,6 @@ Assume point is at the beginning of the block." (and (< (point) block-end-line) (point)))) (contents-end (and contents-begin block-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char block-end-line) (forward-line) (point))) @@ -1388,7 +1491,6 @@ Assume point is at the beginning of the block." (nconc (list :begin begin :end end - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -1409,8 +1511,8 @@ CONTENTS is the contents of the element." LIMIT bounds the search. Return a list whose CAR is `section' and CDR is a plist -containing `:begin', `:end', `:contents-begin', `contents-end' -and `:post-blank' keywords." +containing `:begin', `:end', `:contents-begin', `contents-end', +`:post-blank' and `:post-affiliated' keywords." (save-excursion ;; Beginning of section is the beginning of the first non-blank ;; line after previous headline. @@ -1425,7 +1527,8 @@ and `:post-blank' keywords." :end end :contents-begin begin :contents-end pos-before-blank - :post-blank (count-lines pos-before-blank end)))))) + :post-blank (count-lines pos-before-blank end) + :post-affiliated begin))))) (defun org-element-section-interpreter (section contents) "Interpret SECTION element as Org syntax. @@ -1444,14 +1547,13 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `special-block' and CDR is a plist -containing `:type', `:begin', `:end', `:hiddenp', -`:contents-begin', `:contents-end', `:post-blank' and -`:post-affiliated' keywords. +containing `:type', `:begin', `:end', `:contents-begin', +`:contents-end', `:post-blank' and `:post-affiliated' keywords. Assume point is at the beginning of the block." (let* ((case-fold-search t) (type (progn (looking-at "[ \t]*#\\+BEGIN_\\(\\S-+\\)") - (upcase (match-string-no-properties 1))))) + (match-string-no-properties 1)))) (if (not (save-excursion (re-search-forward (format "^[ \t]*#\\+END_%s[ \t]*$" (regexp-quote type)) @@ -1467,7 +1569,6 @@ Assume point is at the beginning of the block." (and (< (point) block-end-line) (point)))) (contents-end (and contents-begin block-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char block-end-line) (forward-line) (point))) @@ -1478,7 +1579,6 @@ Assume point is at the beginning of the block." (list :type type :begin begin :end end - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -1512,28 +1612,41 @@ CONTENTS is the contents of the element." (defun org-element-babel-call-parser (limit affiliated) "Parse a babel call. -LIMIT bounds the search. AFFILIATED is a list of which CAR is +LIMIT bounds the search. AFFILIATED is a list of which car is the buffer position at the beginning of the first affiliated -keyword and CDR is a plist of affiliated keywords along with +keyword and cdr is a plist of affiliated keywords along with their value. -Return a list whose CAR is `babel-call' and CDR is a plist -containing `:begin', `:end', `:info', `:post-blank' and +Return a list whose car is `babel-call' and cdr is a plist +containing `:call', `:inside-header', `:arguments', +`:end-header', `:begin', `:end', `:value', `:post-blank' and `:post-affiliated' as keywords." (save-excursion - (let ((case-fold-search t) - (info (progn (looking-at org-babel-block-lob-one-liner-regexp) - (org-babel-lob-get-info))) - (begin (car affiliated)) - (post-affiliated (point)) - (pos-before-blank (progn (forward-line) (point))) - (end (progn (skip-chars-forward " \r\t\n" limit) - (if (eobp) (point) (line-beginning-position))))) + (let* ((begin (car affiliated)) + (post-affiliated (point)) + (value (progn (search-forward ":" nil t) + (org-trim + (buffer-substring-no-properties + (point) (line-end-position))))) + (pos-before-blank (progn (forward-line) (point))) + (end (progn (skip-chars-forward " \r\t\n" limit) + (if (eobp) (point) (line-beginning-position)))) + (valid-value + (string-match + "\\([^()\n]+?\\)\\(?:\\[\\(.*?\\)\\]\\)?(\\(.*\\))[ \t]*\\(.*\\)" + value))) (list 'babel-call (nconc - (list :begin begin + (list :call (and valid-value (match-string 1 value)) + :inside-header (and valid-value + (org-string-nw-p (match-string 2 value))) + :arguments (and valid-value + (org-string-nw-p (match-string 3 value))) + :end-header (and valid-value + (org-string-nw-p (match-string 4 value))) + :begin begin :end end - :info info + :value value :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated)))))) @@ -1541,14 +1654,13 @@ containing `:begin', `:end', `:info', `:post-blank' and (defun org-element-babel-call-interpreter (babel-call contents) "Interpret BABEL-CALL element as Org syntax. CONTENTS is nil." - (let* ((babel-info (org-element-property :info babel-call)) - (main (car babel-info)) - (post-options (nth 1 babel-info))) - (concat "#+CALL: " - (if (not (string-match "\\[\\(\\[.*?\\]\\)\\]" main)) main - ;; Remove redundant square brackets. - (replace-match (match-string 1 main) nil nil main)) - (and post-options (format "[%s]" post-options))))) + (concat "#+CALL: " + (org-element-property :call babel-call) + (let ((h (org-element-property :inside-header babel-call))) + (and h (format "[%s]" h))) + (concat "(" (org-element-property :arguments babel-call) ")") + (let ((h (org-element-property :end-header babel-call))) + (and h (concat " " h))))) ;;;; Clock @@ -1559,8 +1671,8 @@ CONTENTS is nil." LIMIT bounds the search. Return a list whose CAR is `clock' and CDR is a plist containing -`:status', `:value', `:time', `:begin', `:end' and `:post-blank' -as keywords." +`:status', `:value', `:time', `:begin', `:end', `:post-blank' and +`:post-affiliated' as keywords." (save-excursion (let* ((case-fold-search nil) (begin (point)) @@ -1584,7 +1696,8 @@ as keywords." :duration duration :begin begin :end end - :post-blank post-blank))))) + :post-blank post-blank + :post-affiliated begin))))) (defun org-element-clock-interpreter (clock contents) "Interpret CLOCK element as Org syntax. @@ -1664,8 +1777,8 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `comment-block' and CDR is a plist -containing `:begin', `:end', `:hiddenp', `:value', `:post-blank' -and `:post-affiliated' keywords. +containing `:begin', `:end', `:value', `:post-blank' and +`:post-affiliated' keywords. Assume point is at comment block beginning." (let ((case-fold-search t)) @@ -1678,7 +1791,6 @@ Assume point is at comment block beginning." (let* ((begin (car affiliated)) (post-affiliated (point)) (contents-begin (progn (forward-line) (point))) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -1691,7 +1803,6 @@ Assume point is at comment block beginning." (list :begin begin :end end :value value - :hiddenp hidden :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated))))))))) @@ -1700,7 +1811,9 @@ Assume point is at comment block beginning." "Interpret COMMENT-BLOCK element as Org syntax. CONTENTS is nil." (format "#+BEGIN_COMMENT\n%s#+END_COMMENT" - (org-remove-indentation (org-element-property :value comment-block)))) + (org-element-normalize-string + (org-remove-indentation + (org-element-property :value comment-block))))) ;;;; Diary Sexp @@ -1741,35 +1854,6 @@ CONTENTS is nil." ;;;; Example Block -(defun org-element--remove-indentation (s &optional n) - "Remove maximum common indentation in string S and return it. -When optional argument N is a positive integer, remove exactly -that much characters from indentation, if possible, or return -S as-is otherwise. Unlike to `org-remove-indentation', this -function doesn't call `untabify' on S." - (catch 'exit - (with-temp-buffer - (insert s) - (goto-char (point-min)) - ;; Find maximum common indentation, if not specified. - (setq n (or n - (let ((min-ind (point-max))) - (save-excursion - (while (re-search-forward "^[ \t]*\\S-" nil t) - (let ((ind (1- (current-column)))) - (if (zerop ind) (throw 'exit s) - (setq min-ind (min min-ind ind)))))) - min-ind))) - (if (zerop n) s - ;; Remove exactly N indentation, but give up if not possible. - (while (not (eobp)) - (let ((ind (progn (skip-chars-forward " \t") (current-column)))) - (cond ((eolp) (delete-region (line-beginning-position) (point))) - ((< ind n) (throw 'exit s)) - (t (org-indent-line-to (- ind n)))) - (forward-line))) - (buffer-string))))) - (defun org-element-example-block-parser (limit affiliated) "Parse an example block. @@ -1780,9 +1864,8 @@ their value. Return a list whose CAR is `example-block' and CDR is a plist containing `:begin', `:end', `:number-lines', `:preserve-indent', -`:retain-labels', `:use-labels', `:label-fmt', `:hiddenp', -`:switches', `:value', `:post-blank' and `:post-affiliated' -keywords." +`:retain-labels', `:use-labels', `:label-fmt', `:switches', +`:value', `:post-blank' and `:post-affiliated' keywords." (let ((case-fold-search t)) (if (not (save-excursion (re-search-forward "^[ \t]*#\\+END_EXAMPLE[ \t]*$" limit t))) @@ -1800,8 +1883,7 @@ keywords." ((string-match "-n\\>" switches) 'new) ((string-match "+n\\>" switches) 'continued))) (preserve-indent - (or org-src-preserve-indentation - (and switches (string-match "-i\\>" switches)))) + (and switches (string-match "-i\\>" switches))) ;; Should labels be retained in (or stripped from) example ;; blocks? (retain-labels @@ -1823,12 +1905,11 @@ keywords." (post-affiliated (point)) (block-ind (progn (skip-chars-forward " \t") (current-column))) (contents-begin (progn (forward-line) (point))) - (hidden (org-invisible-p2)) - (value (org-element--remove-indentation + (value (org-element-remove-indentation (org-unescape-code-in-string (buffer-substring-no-properties contents-begin contents-end)) - (and preserve-indent block-ind))) + block-ind)) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -1845,7 +1926,6 @@ keywords." :retain-labels retain-labels :use-labels use-labels :label-fmt label-fmt - :hiddenp hidden :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated))))))))) @@ -1853,10 +1933,15 @@ keywords." (defun org-element-example-block-interpreter (example-block contents) "Interpret EXAMPLE-BLOCK element as Org syntax. CONTENTS is nil." - (let ((switches (org-element-property :switches example-block))) + (let ((switches (org-element-property :switches example-block)) + (value (org-element-property :value example-block))) (concat "#+BEGIN_EXAMPLE" (and switches (concat " " switches)) "\n" - (org-escape-code-in-string - (org-element-property :value example-block)) + (org-element-normalize-string + (org-escape-code-in-string + (if (or org-src-preserve-indentation + (org-element-property :preserve-indent example-block)) + value + (org-element-remove-indentation value)))) "#+END_EXAMPLE"))) @@ -1871,8 +1956,8 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `export-block' and CDR is a plist -containing `:begin', `:end', `:type', `:hiddenp', `:value', -`:post-blank' and `:post-affiliated' keywords. +containing `:begin', `:end', `:type', `:value', `:post-blank' and +`:post-affiliated' keywords. Assume point is at export-block beginning." (let* ((case-fold-search t) @@ -1888,7 +1973,6 @@ Assume point is at export-block beginning." (let* ((begin (car affiliated)) (post-affiliated (point)) (contents-begin (progn (forward-line) (point))) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -1902,7 +1986,6 @@ Assume point is at export-block beginning." :end end :type type :value value - :hiddenp hidden :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated))))))))) @@ -2015,7 +2098,10 @@ Return a list whose CAR is `keyword' and CDR is a plist containing `:key', `:value', `:begin', `:end', `:post-blank' and `:post-affiliated' keywords." (save-excursion - (let ((begin (car affiliated)) + ;; An orphaned affiliated keyword is considered as a regular + ;; keyword. In this case AFFILIATED is nil, so we take care of + ;; this corner case. + (let ((begin (or (car affiliated) (point))) (post-affiliated (point)) (key (progn (looking-at "[ \t]*#\\+\\(\\S-+*\\):") (upcase (org-match-string-no-properties 1)))) @@ -2044,6 +2130,18 @@ CONTENTS is nil." ;;;; Latex Environment +(defconst org-element--latex-begin-environment + "^[ \t]*\\\\begin{\\([A-Za-z0-9*]+\\)}" + "Regexp matching the beginning of a LaTeX environment. +The environment is captured by the first group. + +See also `org-element--latex-end-environment'.") + +(defconst org-element--latex-end-environment + "\\\\end{%s}[ \t]*$" + "Format string matching the ending of a LaTeX environment. +See also `org-element--latex-begin-environment'.") + (defun org-element-latex-environment-parser (limit affiliated) "Parse a LaTeX environment. @@ -2060,8 +2158,8 @@ Assume point is at the beginning of the latex environment." (save-excursion (let ((case-fold-search t) (code-begin (point))) - (looking-at "[ \t]*\\\\begin{\\([A-Za-z0-9]+\\*?\\)}") - (if (not (re-search-forward (format "^[ \t]*\\\\end{%s}[ \t]*$" + (looking-at org-element--latex-begin-environment) + (if (not (re-search-forward (format org-element--latex-end-environment (regexp-quote (match-string 1))) limit t)) ;; Incomplete latex environment: parse it as a paragraph. @@ -2094,10 +2192,11 @@ CONTENTS is nil." LIMIT bounds the search. Return a list whose CAR is `node-property' and CDR is a plist -containing `:key', `:value', `:begin', `:end' and `:post-blank' -keywords." +containing `:key', `:value', `:begin', `:end', `:post-blank' and +`:post-affiliated' keywords." (looking-at org-property-re) - (let ((begin (point)) + (let ((case-fold-search t) + (begin (point)) (key (org-match-string-no-properties 2)) (value (org-match-string-no-properties 3)) (end (save-excursion @@ -2110,7 +2209,8 @@ keywords." :value value :begin begin :end end - :post-blank 0)))) + :post-blank 0 + :post-affiliated begin)))) (defun org-element-node-property-interpreter (node-property contents) "Interpret NODE-PROPERTY element as Org syntax. @@ -2141,66 +2241,42 @@ Assume point is at the beginning of the paragraph." (before-blank (let ((case-fold-search t)) (end-of-line) - (if (not (re-search-forward - org-element-paragraph-separate limit 'm)) - limit - ;; A matching `org-element-paragraph-separate' is not - ;; necessarily the end of the paragraph. In - ;; particular, lines starting with # or : as a first - ;; non-space character are ambiguous. We have to - ;; check if they are valid Org syntax (e.g., not an - ;; incomplete keyword). - (beginning-of-line) - (while (not - (or - ;; There's no ambiguity for other symbols or - ;; empty lines: stop here. - (looking-at "[ \t]*\\(?:[^:#]\\|$\\)") - ;; Stop at valid fixed-width areas. - (looking-at "[ \t]*:\\(?: \\|$\\)") - ;; Stop at drawers. - (and (looking-at org-drawer-regexp) - (save-excursion - (re-search-forward - "^[ \t]*:END:[ \t]*$" limit t))) - ;; Stop at valid comments. - (looking-at "[ \t]*#\\(?: \\|$\\)") - ;; Stop at valid dynamic blocks. - (and (looking-at org-dblock-start-re) - (save-excursion - (re-search-forward - "^[ \t]*#\\+END:?[ \t]*$" limit t))) - ;; Stop at valid blocks. - (and (looking-at "[ \t]*#\\+BEGIN_\\(\\S-+\\)") - (save-excursion - (re-search-forward - (format "^[ \t]*#\\+END_%s[ \t]*$" - (regexp-quote - (org-match-string-no-properties 1))) - limit t))) - ;; Stop at valid latex environments. - (and (looking-at - "[ \t]*\\\\begin{\\([A-Za-z0-9]+\\*?\\)}") - (save-excursion - (re-search-forward - (format "^[ \t]*\\\\end{%s}[ \t]*$" - (regexp-quote - (org-match-string-no-properties 1))) - limit t))) - ;; Stop at valid keywords. - (looking-at "[ \t]*#\\+\\S-+:") - ;; Skip everything else. - (not - (progn - (end-of-line) - (re-search-forward org-element-paragraph-separate - limit 'm))))) - (beginning-of-line))) + ;; A matching `org-element-paragraph-separate' is not + ;; necessarily the end of the paragraph. In particular, + ;; drawers, blocks or LaTeX environments opening lines + ;; must be closed. Moreover keywords with a secondary + ;; value must belong to "dual keywords". + (while (not + (cond + ((not (and (re-search-forward + org-element-paragraph-separate limit 'move) + (progn (beginning-of-line) t)))) + ((looking-at org-drawer-regexp) + (save-excursion + (re-search-forward "^[ \t]*:END:[ \t]*$" limit t))) + ((looking-at "[ \t]*#\\+BEGIN_\\(\\S-+\\)") + (save-excursion + (re-search-forward + (format "^[ \t]*#\\+END_%s[ \t]*$" + (regexp-quote (match-string 1))) + limit t))) + ((looking-at org-element--latex-begin-environment) + (save-excursion + (re-search-forward + (format org-element--latex-end-environment + (regexp-quote (match-string 1))) + limit t))) + ((looking-at "[ \t]*#\\+\\(\\S-+\\)\\[.*\\]:") + (member-ignore-case (match-string 1) + org-element-dual-keywords)) + ;; Everything else is unambiguous. + (t))) + (end-of-line)) (if (= (point) limit) limit (goto-char (line-beginning-position))))) - (contents-end (progn (skip-chars-backward " \r\t\n" contents-begin) - (forward-line) - (point))) + (contents-end (save-excursion + (skip-chars-backward " \r\t\n" contents-begin) + (line-beginning-position 2))) (end (progn (skip-chars-forward " \r\t\n" limit) (if (eobp) (point) (line-beginning-position))))) (list 'paragraph @@ -2227,8 +2303,8 @@ CONTENTS is the contents of the element." LIMIT bounds the search. Return a list whose CAR is `planning' and CDR is a plist -containing `:closed', `:deadline', `:scheduled', `:begin', `:end' -and `:post-blank' keywords." +containing `:closed', `:deadline', `:scheduled', `:begin', +`:end', `:post-blank' and `:post-affiliated' keywords." (save-excursion (let* ((case-fold-search nil) (begin (point)) @@ -2254,7 +2330,8 @@ and `:post-blank' keywords." :scheduled scheduled :begin begin :end end - :post-blank post-blank))))) + :post-blank post-blank + :post-affiliated begin))))) (defun org-element-planning-interpreter (planning contents) "Interpret PLANNING element as Org syntax. @@ -2277,37 +2354,6 @@ CONTENTS is nil." " ")) -;;;; Quote Section - -(defun org-element-quote-section-parser (limit) - "Parse a quote section. - -LIMIT bounds the search. - -Return a list whose CAR is `quote-section' and CDR is a plist -containing `:begin', `:end', `:value' and `:post-blank' keywords. - -Assume point is at beginning of the section." - (save-excursion - (let* ((begin (point)) - (end (progn (org-with-limited-levels (outline-next-heading)) - (point))) - (pos-before-blank (progn (skip-chars-backward " \r\t\n") - (forward-line) - (point))) - (value (buffer-substring-no-properties begin pos-before-blank))) - (list 'quote-section - (list :begin begin - :end end - :value value - :post-blank (count-lines pos-before-blank end)))))) - -(defun org-element-quote-section-interpreter (quote-section contents) - "Interpret QUOTE-SECTION element as Org syntax. -CONTENTS is nil." - (org-element-property :value quote-section)) - - ;;;; Src Block (defun org-element-src-block-parser (limit affiliated) @@ -2320,9 +2366,9 @@ their value. Return a list whose CAR is `src-block' and CDR is a plist containing `:language', `:switches', `:parameters', `:begin', -`:end', `:hiddenp', `:number-lines', `:retain-labels', -`:use-labels', `:label-fmt', `:preserve-indent', `:value', -`:post-blank' and `:post-affiliated' keywords. +`:end', `:number-lines', `:retain-labels', `:use-labels', +`:label-fmt', `:preserve-indent', `:value', `:post-blank' and +`:post-affiliated' keywords. Assume point is at the beginning of the block." (let ((case-fold-search t)) @@ -2352,9 +2398,8 @@ Assume point is at the beginning of the block." (cond ((not switches) nil) ((string-match "-n\\>" switches) 'new) ((string-match "+n\\>" switches) 'continued))) - (preserve-indent (or org-src-preserve-indentation - (and switches - (string-match "-i\\>" switches)))) + (preserve-indent (and switches + (string-match "-i\\>" switches))) (label-fmt (and switches (string-match "-l +\"\\([^\"\n]+\\)\"" switches) @@ -2373,14 +2418,12 @@ Assume point is at the beginning of the block." (not (string-match "-k\\>" switches))))) ;; Indentation. (block-ind (progn (skip-chars-forward " \t") (current-column))) - ;; Get visibility status. - (hidden (progn (forward-line) (org-invisible-p2))) ;; Retrieve code. - (value (org-element--remove-indentation + (value (org-element-remove-indentation (org-unescape-code-in-string (buffer-substring-no-properties - (point) contents-end)) - (and preserve-indent block-ind))) + (progn (forward-line) (point)) contents-end)) + block-ind)) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -2401,7 +2444,6 @@ Assume point is at the beginning of the block." :retain-labels retain-labels :use-labels use-labels :label-fmt label-fmt - :hiddenp hidden :value value :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) @@ -2413,20 +2455,22 @@ CONTENTS is nil." (let ((lang (org-element-property :language src-block)) (switches (org-element-property :switches src-block)) (params (org-element-property :parameters src-block)) - (value (let ((val (org-element-property :value src-block))) - (cond - ((org-element-property :preserve-indent src-block) val) - ((zerop org-edit-src-content-indentation) val) - (t - (let ((ind (make-string - org-edit-src-content-indentation 32))) - (replace-regexp-in-string - "\\(^\\)[ \t]*\\S-" ind val nil nil 1))))))) + (value + (let ((val (org-element-property :value src-block))) + (cond + ((or org-src-preserve-indentation + (org-element-property :preserve-indent src-block)) + val) + ((zerop org-edit-src-content-indentation) val) + (t + (let ((ind (make-string org-edit-src-content-indentation ?\s))) + (replace-regexp-in-string + "\\(^\\)[ \t]*\\S-" ind val nil nil 1))))))) (concat (format "#+BEGIN_SRC%s\n" (concat (and lang (concat " " lang)) (and switches (concat " " switches)) (and params (concat " " params)))) - (org-escape-code-in-string value) + (org-element-normalize-string (org-escape-code-in-string value)) "#+END_SRC"))) @@ -2449,10 +2493,12 @@ Assume point is at the beginning of the table." (save-excursion (let* ((case-fold-search t) (table-begin (point)) - (type (if (org-at-table.el-p) 'table.el 'org)) + (type (if (looking-at "[ \t]*|") 'org 'table.el)) + (end-re (format "^[ \t]*\\($\\|[^| \t%s]\\)" + (if (eq type 'org) "" "+"))) (begin (car affiliated)) (table-end - (if (re-search-forward org-table-any-border-regexp limit 'm) + (if (re-search-forward end-re limit 'move) (goto-char (match-beginning 0)) (point))) (tblfm (let (acc) @@ -2503,7 +2549,7 @@ LIMIT bounds the search. Return a list whose CAR is `table-row' and CDR is a plist containing `:begin', `:end', `:contents-begin', `:contents-end', -`:type' and `:post-blank' keywords." +`:type', `:post-blank' and `:post-affiliated' keywords." (save-excursion (let* ((type (if (looking-at "^[ \t]*|-") 'rule 'standard)) (begin (point)) @@ -2517,14 +2563,15 @@ containing `:begin', `:end', `:contents-begin', `:contents-end', (end-of-line) (skip-chars-backward " \t") (point)))) - (end (progn (forward-line) (point)))) + (end (line-beginning-position 2))) (list 'table-row (list :type type :begin begin :end end :contents-begin contents-begin :contents-end contents-end - :post-blank 0))))) + :post-blank 0 + :post-affiliated begin))))) (defun org-element-table-row-interpreter (table-row contents) "Interpret TABLE-ROW element as Org syntax. @@ -2545,7 +2592,7 @@ their value. Return a list whose CAR is `verse-block' and CDR is a plist containing `:begin', `:end', `:contents-begin', `:contents-end', -`:hiddenp', `:post-blank' and `:post-affiliated' keywords. +`:post-blank' and `:post-affiliated' keywords. Assume point is at beginning of the block." (let ((case-fold-search t)) @@ -2557,8 +2604,7 @@ Assume point is at beginning of the block." (save-excursion (let* ((begin (car affiliated)) (post-affiliated (point)) - (hidden (progn (forward-line) (org-invisible-p2))) - (contents-begin (point)) + (contents-begin (progn (forward-line) (point))) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -2570,7 +2616,6 @@ Assume point is at beginning of the block." :end end :contents-begin contents-begin :contents-end contents-end - :hiddenp hidden :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated))))))))) @@ -2584,104 +2629,75 @@ CONTENTS is verse block contents." ;;; Objects ;; -;; Unlike to elements, interstices can be found between objects. -;; That's why, along with the parser, successor functions are provided -;; for each object. Some objects share the same successor (e.g., -;; `code' and `verbatim' objects). -;; -;; A successor must accept a single argument bounding the search. It -;; will return either a cons cell whose CAR is the object's type, as -;; a symbol, and CDR the position of its next occurrence, or nil. -;; -;; Successors follow the naming convention: -;; org-element-NAME-successor, where NAME is the name of the -;; successor, as defined in `org-element-all-successors'. +;; Unlike to elements, raw text can be found between objects. Hence, +;; `org-element--object-lex' is provided to find the next object in +;; buffer. ;; ;; Some object types (e.g., `italic') are recursive. Restrictions on ;; object types they can contain will be specified in ;; `org-element-object-restrictions'. ;; -;; Adding a new type of object is simple. Implement a successor, -;; a parser, and an interpreter for it, all following the naming -;; convention. Register type in `org-element-all-objects' and -;; successor in `org-element-all-successors'. Maybe tweak -;; restrictions about it, and that's it. - +;; Creating a new type of object requires to alter +;; `org-element--object-regexp' and `org-element--object-lex', add the +;; new type in `org-element-all-objects', and possibly add +;; restrictions in `org-element-object-restrictions'. ;;;; Bold (defun org-element-bold-parser () - "Parse bold object at point. + "Parse bold object at point, if any. -Return a list whose CAR is `bold' and CDR is a plist with -`:begin', `:end', `:contents-begin' and `:contents-end' and -`:post-blank' keywords. +When at a bold object, return a list whose car is `bold' and cdr +is a plist with `:begin', `:end', `:contents-begin' and +`:contents-end' and `:post-blank' keywords. Otherwise, return +nil. Assume point is at the first star marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (contents-begin (match-beginning 4)) - (contents-end (match-end 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'bold - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (contents-begin (match-beginning 4)) + (contents-end (match-end 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'bold + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-bold-interpreter (bold contents) "Interpret BOLD object as Org syntax. CONTENTS is the contents of the object." (format "*%s*" contents)) -(defun org-element-text-markup-successor () - "Search for the next text-markup object. - -Return value is a cons cell whose CAR is a symbol among `bold', -`italic', `underline', `strike-through', `code' and `verbatim' -and CDR is beginning position." - (save-excursion - (unless (bolp) (backward-char)) - (when (re-search-forward org-emph-re nil t) - (let ((marker (match-string 3))) - (cons (cond - ((equal marker "*") 'bold) - ((equal marker "/") 'italic) - ((equal marker "_") 'underline) - ((equal marker "+") 'strike-through) - ((equal marker "~") 'code) - ((equal marker "=") 'verbatim) - (t (error "Unknown marker at %d" (match-beginning 3)))) - (match-beginning 2)))))) - ;;;; Code (defun org-element-code-parser () - "Parse code object at point. + "Parse code object at point, if any. -Return a list whose CAR is `code' and CDR is a plist with -`:value', `:begin', `:end' and `:post-blank' keywords. +When at a code object, return a list whose car is `code' and cdr +is a plist with `:value', `:begin', `:end' and `:post-blank' +keywords. Otherwise, return nil. Assume point is at the first tilde marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (value (org-match-string-no-properties 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'code - (list :value value - :begin begin - :end end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (value (org-match-string-no-properties 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'code + (list :value value + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-code-interpreter (code contents) "Interpret CODE object as Org syntax. @@ -2692,35 +2708,37 @@ CONTENTS is nil." ;;;; Entity (defun org-element-entity-parser () - "Parse entity at point. + "Parse entity at point, if any. -Return a list whose CAR is `entity' and CDR a plist with -`:begin', `:end', `:latex', `:latex-math-p', `:html', `:latin1', -`:utf-8', `:ascii', `:use-brackets-p' and `:post-blank' as -keywords. +When at an entity, return a list whose car is `entity' and cdr +a plist with `:begin', `:end', `:latex', `:latex-math-p', +`:html', `:latin1', `:utf-8', `:ascii', `:use-brackets-p' and +`:post-blank' as keywords. Otherwise, return nil. Assume point is at the beginning of the entity." - (save-excursion - (looking-at "\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\($\\|{}\\|[^[:alpha:]]\\)") - (let* ((value (org-entity-get (match-string 1))) - (begin (match-beginning 0)) - (bracketsp (string= (match-string 2) "{}")) - (post-blank (progn (goto-char (match-end 1)) - (when bracketsp (forward-char 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'entity - (list :name (car value) - :latex (nth 1 value) - :latex-math-p (nth 2 value) - :html (nth 3 value) - :ascii (nth 4 value) - :latin1 (nth 5 value) - :utf-8 (nth 6 value) - :begin begin - :end end - :use-brackets-p bracketsp - :post-blank post-blank))))) + (catch 'no-object + (when (looking-at "\\\\\\(?:\\(?1:_ +\\)\\|\\(?1:there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\(?2:$\\|{}\\|[^[:alpha:]]\\)\\)") + (save-excursion + (let* ((value (or (org-entity-get (match-string 1)) + (throw 'no-object nil))) + (begin (match-beginning 0)) + (bracketsp (string= (match-string 2) "{}")) + (post-blank (progn (goto-char (match-end 1)) + (when bracketsp (forward-char 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'entity + (list :name (car value) + :latex (nth 1 value) + :latex-math-p (nth 2 value) + :html (nth 3 value) + :ascii (nth 4 value) + :latin1 (nth 5 value) + :utf-8 (nth 6 value) + :begin begin + :end end + :use-brackets-p bracketsp + :post-blank post-blank))))))) (defun org-element-entity-interpreter (entity contents) "Interpret ENTITY object as Org syntax. @@ -2729,59 +2747,37 @@ CONTENTS is nil." (org-element-property :name entity) (when (org-element-property :use-brackets-p entity) "{}"))) -(defun org-element-latex-or-entity-successor () - "Search for the next latex-fragment or entity object. - -Return value is a cons cell whose CAR is `entity' or -`latex-fragment' and CDR is beginning position." - (save-excursion - (unless (bolp) (backward-char)) - (let ((matchers (cdr org-latex-regexps)) - ;; ENTITY-RE matches both LaTeX commands and Org entities. - (entity-re - "\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\($\\|{}\\|[^[:alpha:]]\\)")) - (when (re-search-forward - (concat (mapconcat #'cadr matchers "\\|") "\\|" entity-re) nil t) - (goto-char (match-beginning 0)) - (if (looking-at entity-re) - ;; Determine if it's a real entity or a LaTeX command. - (cons (if (org-entity-get (match-string 1)) 'entity 'latex-fragment) - (match-beginning 0)) - ;; No entity nor command: point is at a LaTeX fragment. - ;; Determine its type to get the correct beginning position. - (cons 'latex-fragment - (catch 'return - (dolist (e matchers) - (when (looking-at (nth 1 e)) - (throw 'return (match-beginning (nth 2 e))))) - (point)))))))) - ;;;; Export Snippet (defun org-element-export-snippet-parser () "Parse export snippet at point. -Return a list whose CAR is `export-snippet' and CDR a plist with -`:begin', `:end', `:back-end', `:value' and `:post-blank' as -keywords. +When at an export snippet, return a list whose car is +`export-snippet' and cdr a plist with `:begin', `:end', +`:back-end', `:value' and `:post-blank' as keywords. Otherwise, +return nil. Assume point is at the beginning of the snippet." (save-excursion - (re-search-forward "@@\\([-A-Za-z0-9]+\\):" nil t) - (let* ((begin (match-beginning 0)) - (back-end (org-match-string-no-properties 1)) - (value (buffer-substring-no-properties - (point) - (progn (re-search-forward "@@" nil t) (match-beginning 0)))) - (post-blank (skip-chars-forward " \t")) - (end (point))) - (list 'export-snippet - (list :back-end back-end - :value value - :begin begin - :end end - :post-blank post-blank))))) + (let (contents-end) + (when (and (looking-at "@@\\([-A-Za-z0-9]+\\):") + (setq contents-end + (save-match-data (goto-char (match-end 0)) + (re-search-forward "@@" nil t) + (match-beginning 0)))) + (let* ((begin (match-beginning 0)) + (back-end (org-match-string-no-properties 1)) + (value (buffer-substring-no-properties + (match-end 0) contents-end)) + (post-blank (skip-chars-forward " \t")) + (end (point))) + (list 'export-snippet + (list :back-end back-end + :value value + :begin begin + :end end + :post-blank post-blank))))))) (defun org-element-export-snippet-interpreter (export-snippet contents) "Interpret EXPORT-SNIPPET object as Org syntax. @@ -2790,163 +2786,124 @@ CONTENTS is nil." (org-element-property :back-end export-snippet) (org-element-property :value export-snippet))) -(defun org-element-export-snippet-successor () - "Search for the next export-snippet object. - -Return value is a cons cell whose CAR is `export-snippet' and CDR -its beginning position." - (save-excursion - (let (beg) - (when (and (re-search-forward "@@[-A-Za-z0-9]+:" nil t) - (setq beg (match-beginning 0)) - (search-forward "@@" nil t)) - (cons 'export-snippet beg))))) - ;;;; Footnote Reference (defun org-element-footnote-reference-parser () - "Parse footnote reference at point. - -Return a list whose CAR is `footnote-reference' and CDR a plist -with `:label', `:type', `:inline-definition', `:begin', `:end' -and `:post-blank' as keywords." - (save-excursion - (looking-at org-footnote-re) - (let* ((begin (point)) - (label (or (org-match-string-no-properties 2) + "Parse footnote reference at point, if any. + +When at a footnote reference, return a list whose car is +`footnote-reference' and cdr a plist with `:label', `:type', +`:begin', `:end', `:content-begin', `:contents-end' and +`:post-blank' as keywords. Otherwise, return nil." + (when (looking-at org-footnote-re) + (let ((closing (with-syntax-table org-element--pair-square-table + (ignore-errors (scan-lists (point) 1 0))))) + (when closing + (save-excursion + (let* ((begin (point)) + (label + (or (org-match-string-no-properties 2) (org-match-string-no-properties 3) (and (match-string 1) (concat "fn:" (org-match-string-no-properties 1))))) - (type (if (or (not label) (match-string 1)) 'inline 'standard)) - (inner-begin (match-end 0)) - (inner-end - (let ((count 1)) - (forward-char) - (while (and (> count 0) (re-search-forward "[][]" nil t)) - (if (equal (match-string 0) "[") (incf count) (decf count))) - (1- (point)))) - (post-blank (progn (goto-char (1+ inner-end)) - (skip-chars-forward " \t"))) - (end (point)) - (footnote-reference + (type (if (or (not label) (match-string 1)) 'inline 'standard)) + (inner-begin (match-end 0)) + (inner-end (1- closing)) + (post-blank (progn (goto-char closing) + (skip-chars-forward " \t"))) + (end (point))) (list 'footnote-reference (list :label label :type type :begin begin :end end - :post-blank post-blank)))) - (org-element-put-property - footnote-reference :inline-definition - (and (eq type 'inline) - (org-element-parse-secondary-string - (buffer-substring inner-begin inner-end) - (org-element-restriction 'footnote-reference) - footnote-reference)))))) + :contents-begin (and (eq type 'inline) inner-begin) + :contents-end (and (eq type 'inline) inner-end) + :post-blank post-blank)))))))) (defun org-element-footnote-reference-interpreter (footnote-reference contents) "Interpret FOOTNOTE-REFERENCE object as Org syntax. -CONTENTS is nil." - (let ((label (or (org-element-property :label footnote-reference) "fn:")) - (def - (let ((inline-def - (org-element-property :inline-definition footnote-reference))) - (if (not inline-def) "" - (concat ":" (org-element-interpret-data inline-def)))))) - (format "[%s]" (concat label def)))) - -(defun org-element-footnote-reference-successor () - "Search for the next footnote-reference object. - -Return value is a cons cell whose CAR is `footnote-reference' and -CDR is beginning position." - (save-excursion - (catch 'exit - (while (re-search-forward org-footnote-re nil t) - (save-excursion - (let ((beg (match-beginning 0)) - (count 1)) - (backward-char) - (while (re-search-forward "[][]" nil t) - (if (equal (match-string 0) "[") (incf count) (decf count)) - (when (zerop count) - (throw 'exit (cons 'footnote-reference beg)))))))))) +CONTENTS is its definition, when inline, or nil." + (format "[%s]" + (concat (or (org-element-property :label footnote-reference) "fn:") + (and contents (concat ":" contents))))) ;;;; Inline Babel Call (defun org-element-inline-babel-call-parser () - "Parse inline babel call at point. + "Parse inline babel call at point, if any. -Return a list whose CAR is `inline-babel-call' and CDR a plist -with `:begin', `:end', `:info' and `:post-blank' as keywords. +When at an inline babel call, return a list whose car is +`inline-babel-call' and cdr a plist with `:call', +`:inside-header', `:arguments', `:end-header', `:begin', `:end', +`:value' and `:post-blank' as keywords. Otherwise, return nil. Assume point is at the beginning of the babel call." (save-excursion (unless (bolp) (backward-char)) - (looking-at org-babel-inline-lob-one-liner-regexp) - (let ((info (save-match-data (org-babel-lob-get-info))) - (begin (match-end 1)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'inline-babel-call - (list :begin begin - :end end - :info info - :post-blank post-blank))))) + (when (let ((case-fold-search t)) + (looking-at org-babel-inline-lob-one-liner-regexp)) + (let ((begin (match-end 1)) + (call (org-match-string-no-properties 2)) + (inside-header (org-string-nw-p (org-match-string-no-properties 4))) + (arguments (org-string-nw-p (org-match-string-no-properties 6))) + (end-header (org-string-nw-p (org-match-string-no-properties 8))) + (value (buffer-substring-no-properties (match-end 1) (match-end 0))) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'inline-babel-call + (list :call call + :inside-header inside-header + :arguments arguments + :end-header end-header + :begin begin + :end end + :value value + :post-blank post-blank)))))) (defun org-element-inline-babel-call-interpreter (inline-babel-call contents) "Interpret INLINE-BABEL-CALL object as Org syntax. CONTENTS is nil." - (let* ((babel-info (org-element-property :info inline-babel-call)) - (main-source (car babel-info)) - (post-options (nth 1 babel-info))) - (concat "call_" - (if (string-match "\\[\\(\\[.*?\\]\\)\\]" main-source) - ;; Remove redundant square brackets. - (replace-match - (match-string 1 main-source) nil nil main-source) - main-source) - (and post-options (format "[%s]" post-options))))) - -(defun org-element-inline-babel-call-successor () - "Search for the next inline-babel-call object. - -Return value is a cons cell whose CAR is `inline-babel-call' and -CDR is beginning position." - (save-excursion - (when (re-search-forward org-babel-inline-lob-one-liner-regexp nil t) - (cons 'inline-babel-call (match-end 1))))) + (concat "call_" + (org-element-property :call inline-babel-call) + (let ((h (org-element-property :inside-header inline-babel-call))) + (and h (format "[%s]" h))) + "(" (org-element-property :arguments inline-babel-call) ")" + (let ((h (org-element-property :end-header inline-babel-call))) + (and h (format "[%s]" h))))) ;;;; Inline Src Block (defun org-element-inline-src-block-parser () - "Parse inline source block at point. + "Parse inline source block at point, if any. -Return a list whose CAR is `inline-src-block' and CDR a plist -with `:begin', `:end', `:language', `:value', `:parameters' and -`:post-blank' as keywords. +When at an inline source block, return a list whose car is +`inline-src-block' and cdr a plist with `:begin', `:end', +`:language', `:value', `:parameters' and `:post-blank' as +keywords. Otherwise, return nil. Assume point is at the beginning of the inline src block." (save-excursion (unless (bolp) (backward-char)) - (looking-at org-babel-inline-src-block-regexp) - (let ((begin (match-beginning 1)) - (language (org-match-string-no-properties 2)) - (parameters (org-match-string-no-properties 4)) - (value (org-match-string-no-properties 5)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'inline-src-block - (list :language language - :value value - :parameters parameters - :begin begin - :end end - :post-blank post-blank))))) + (when (looking-at org-babel-inline-src-block-regexp) + (let ((begin (match-beginning 1)) + (language (org-match-string-no-properties 2)) + (parameters (org-match-string-no-properties 4)) + (value (org-match-string-no-properties 5)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'inline-src-block + (list :language language + :value value + :parameters parameters + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-inline-src-block-interpreter (inline-src-block contents) "Interpret INLINE-SRC-BLOCK object as Org syntax. @@ -2959,41 +2916,32 @@ CONTENTS is nil." (if arguments (format "[%s]" arguments) "") body))) -(defun org-element-inline-src-block-successor () - "Search for the next inline-babel-call element. - -Return value is a cons cell whose CAR is `inline-babel-call' and -CDR is beginning position." - (save-excursion - (unless (bolp) (backward-char)) - (when (re-search-forward org-babel-inline-src-block-regexp nil t) - (cons 'inline-src-block (match-beginning 1))))) - ;;;; Italic (defun org-element-italic-parser () - "Parse italic object at point. + "Parse italic object at point, if any. -Return a list whose CAR is `italic' and CDR is a plist with -`:begin', `:end', `:contents-begin' and `:contents-end' and -`:post-blank' keywords. +When at an italic object, return a list whose car is `italic' and +cdr is a plist with `:begin', `:end', `:contents-begin' and +`:contents-end' and `:post-blank' keywords. Otherwise, return +nil. Assume point is at the first slash marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (contents-begin (match-beginning 4)) - (contents-end (match-end 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'italic - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (contents-begin (match-beginning 4)) + (contents-end (match-end 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'italic + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-italic-interpreter (italic contents) "Interpret ITALIC object as Org syntax. @@ -3004,36 +2952,42 @@ CONTENTS is the contents of the object." ;;;; Latex Fragment (defun org-element-latex-fragment-parser () - "Parse LaTeX fragment at point. + "Parse LaTeX fragment at point, if any. -Return a list whose CAR is `latex-fragment' and CDR a plist with -`:value', `:begin', `:end', and `:post-blank' as keywords. +When at a LaTeX fragment, return a list whose car is +`latex-fragment' and cdr a plist with `:value', `:begin', `:end', +and `:post-blank' as keywords. Otherwise, return nil. Assume point is at the beginning of the LaTeX fragment." - (save-excursion - (let* ((begin (point)) - (substring-match - (catch 'exit - (dolist (e (cdr org-latex-regexps)) - (let ((latex-regexp (nth 1 e))) - (when (or (looking-at latex-regexp) - (and (not (bobp)) - (save-excursion - (backward-char) - (looking-at latex-regexp)))) - (throw 'exit (nth 2 e))))) - ;; None found: it's a macro. - (looking-at "\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*") - 0)) - (value (org-match-string-no-properties substring-match)) - (post-blank (progn (goto-char (match-end substring-match)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'latex-fragment - (list :value value - :begin begin - :end end - :post-blank post-blank))))) + (catch 'no-object + (save-excursion + (let* ((begin (point)) + (after-fragment + (if (eq (char-after) ?$) + (if (eq (char-after (1+ (point))) ?$) + (search-forward "$$" nil t 2) + (and (not (eq (char-before) ?$)) + (search-forward "$" nil t 2) + (not (memq (char-before (match-beginning 0)) + '(?\s ?\t ?\n ?, ?.))) + (looking-at "\\(\\s.\\|\\s-\\|\\s(\\|\\s)\\|\\s\"\\|$\\)") + (point))) + (case (char-after (1+ (point))) + (?\( (search-forward "\\)" nil t)) + (?\[ (search-forward "\\]" nil t)) + (otherwise + ;; Macro. + (and (looking-at "\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*") + (match-end 0)))))) + (post-blank (if (not after-fragment) (throw 'no-object nil) + (goto-char after-fragment) + (skip-chars-forward " \t"))) + (end (point))) + (list 'latex-fragment + (list :value (buffer-substring-no-properties begin after-fragment) + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-latex-fragment-interpreter (latex-fragment contents) "Interpret LATEX-FRAGMENT object as Org syntax. @@ -3043,138 +2997,146 @@ CONTENTS is nil." ;;;; Line Break (defun org-element-line-break-parser () - "Parse line break at point. + "Parse line break at point, if any. -Return a list whose CAR is `line-break', and CDR a plist with -`:begin', `:end' and `:post-blank' keywords. +When at a line break, return a list whose car is `line-break', +and cdr a plist with `:begin', `:end' and `:post-blank' keywords. +Otherwise, return nil. Assume point is at the beginning of the line break." - (list 'line-break - (list :begin (point) - :end (progn (forward-line) (point)) - :post-blank 0))) + (when (and (org-looking-at-p "\\\\\\\\[ \t]*$") + (not (eq (char-before) ?\\))) + (list 'line-break + (list :begin (point) + :end (line-beginning-position 2) + :post-blank 0)))) (defun org-element-line-break-interpreter (line-break contents) "Interpret LINE-BREAK object as Org syntax. CONTENTS is nil." "\\\\\n") -(defun org-element-line-break-successor () - "Search for the next line-break object. - -Return value is a cons cell whose CAR is `line-break' and CDR is -beginning position." - (save-excursion - (let ((beg (and (re-search-forward "[^\\\\]\\(\\\\\\\\\\)[ \t]*$" nil t) - (goto-char (match-beginning 1))))) - ;; A line break can only happen on a non-empty line. - (when (and beg (re-search-backward "\\S-" (point-at-bol) t)) - (cons 'line-break beg))))) - ;;;; Link (defun org-element-link-parser () - "Parse link at point. + "Parse link at point, if any. -Return a list whose CAR is `link' and CDR a plist with `:type', -`:path', `:raw-link', `:application', `:search-option', `:begin', -`:end', `:contents-begin', `:contents-end' and `:post-blank' as -keywords. +When at a link, return a list whose car is `link' and cdr a plist +with `:type', `:path', `:raw-link', `:application', +`:search-option', `:begin', `:end', `:contents-begin', +`:contents-end' and `:post-blank' as keywords. Otherwise, return +nil. Assume point is at the beginning of the link." - (save-excursion + (catch 'no-object (let ((begin (point)) end contents-begin contents-end link-end post-blank path type raw-link link search-option application) (cond ;; Type 1: Text targeted from a radio target. - ((and org-target-link-regexp (looking-at org-target-link-regexp)) + ((and org-target-link-regexp + (save-excursion (or (bolp) (backward-char)) + (looking-at org-target-link-regexp))) (setq type "radio" - link-end (match-end 0) - path (org-match-string-no-properties 0) - contents-begin (match-beginning 0) - contents-end (match-end 0))) + link-end (match-end 1) + path (org-match-string-no-properties 1) + contents-begin (match-beginning 1) + contents-end (match-end 1))) ;; Type 2: Standard link, i.e. [[http://orgmode.org][homepage]] ((looking-at org-bracket-link-regexp) - (setq contents-begin (match-beginning 3) - contents-end (match-end 3) - link-end (match-end 0) - ;; RAW-LINK is the original link. Expand any - ;; abbreviation in it. - raw-link (org-translate-link + (setq contents-begin (match-beginning 3)) + (setq contents-end (match-end 3)) + (setq link-end (match-end 0)) + ;; RAW-LINK is the original link. Expand any + ;; abbreviation in it. + ;; + ;; Also treat any newline character and associated + ;; indentation as a single space character. This is not + ;; compatible with RFC 3986, which requires to ignore + ;; them altogether. However, doing so would require + ;; users to encode spaces on the fly when writing links + ;; (e.g., insert [[shell:ls%20*.org]] instead of + ;; [[shell:ls *.org]], which defeats Org's focus on + ;; simplicity. + (setq raw-link (org-translate-link (org-link-expand-abbrev - (org-match-string-no-properties 1)))) - ;; Determine TYPE of link and set PATH accordingly. + (replace-regexp-in-string + "[ \t]*\n[ \t]*" " " + (org-match-string-no-properties 1))))) + ;; Determine TYPE of link and set PATH accordingly. According + ;; to RFC 3986, remove whitespaces from URI in external links. + ;; In internal ones, treat indentation as a single space. (cond ;; File type. ((or (file-name-absolute-p raw-link) (string-match "\\`\\.\\.?/" raw-link)) - (setq type "file" path raw-link)) + (setq type "file") + (setq path raw-link)) ;; Explicit type (http, irc, bbdb...). See `org-link-types'. ((string-match org-link-types-re raw-link) - (setq type (match-string 1 raw-link) - ;; According to RFC 3986, extra whitespace should be - ;; ignored when a URI is extracted. - path (replace-regexp-in-string - "[ \t]*\n[ \t]*" "" (substring raw-link (match-end 0))))) + (setq type (match-string 1 raw-link)) + (setq path (substring raw-link (match-end 0)))) ;; Id type: PATH is the id. - ((string-match "\\`id:\\([-a-f0-9]+\\)" raw-link) + ((string-match "\\`id:\\([-a-f0-9]+\\)\\'" raw-link) (setq type "id" path (match-string 1 raw-link))) ;; Code-ref type: PATH is the name of the reference. - ((string-match "\\`(\\(.*\\))\\'" raw-link) - (setq type "coderef" path (match-string 1 raw-link))) + ((and (org-string-match-p "\\`(" raw-link) + (org-string-match-p ")\\'" raw-link)) + (setq type "coderef") + (setq path (substring raw-link 1 -1))) ;; Custom-id type: PATH is the name of the custom id. - ((= (aref raw-link 0) ?#) - (setq type "custom-id" path (substring raw-link 1))) + ((= (string-to-char raw-link) ?#) + (setq type "custom-id") + (setq path (substring raw-link 1))) ;; Fuzzy type: Internal link either matches a target, an ;; headline name or nothing. PATH is the target or ;; headline's name. - (t (setq type "fuzzy" path raw-link)))) + (t + (setq type "fuzzy") + (setq path raw-link)))) ;; Type 3: Plain link, e.g., http://orgmode.org ((looking-at org-plain-link-re) (setq raw-link (org-match-string-no-properties 0) type (org-match-string-no-properties 1) link-end (match-end 0) path (org-match-string-no-properties 2))) - ;; Type 4: Angular link, e.g., <http://orgmode.org> + ;; Type 4: Angular link, e.g., <http://orgmode.org>. Unlike to + ;; bracket links, follow RFC 3986 and remove any extra + ;; whitespace in URI. ((looking-at org-angle-link-re) - (setq raw-link (buffer-substring-no-properties - (match-beginning 1) (match-end 2)) - type (org-match-string-no-properties 1) - link-end (match-end 0) - path (org-match-string-no-properties 2)))) + (setq type (org-match-string-no-properties 1)) + (setq link-end (match-end 0)) + (setq raw-link + (buffer-substring-no-properties + (match-beginning 1) (match-end 2))) + (setq path (replace-regexp-in-string + "[ \t]*\n[ \t]*" "" (org-match-string-no-properties 2)))) + (t (throw 'no-object nil))) ;; In any case, deduce end point after trailing white space from ;; LINK-END variable. - (setq post-blank (progn (goto-char link-end) (skip-chars-forward " \t")) - end (point)) - ;; Special "file" type link processing. - (when (member type org-element-link-type-is-file) - ;; Extract opening application and search option. - (cond ((string-match "^file\\+\\(.*\\)$" type) - (setq application (match-string 1 type))) - ((not (string-match "^file" type)) - (setq application type))) - (when (string-match "::\\(.*\\)\\'" path) - (setq search-option (match-string 1 path) - path (replace-match "" nil nil path))) - ;; Normalize URI. - (when (and (not (org-string-match-p "\\`//" path)) - (file-name-absolute-p path)) - (setq path (concat "//" (expand-file-name path)))) - ;; Make sure TYPE always reports "file". - (setq type "file")) - (list 'link - (list :type type - :path path - :raw-link (or raw-link path) - :application application - :search-option search-option - :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (save-excursion + (setq post-blank (progn (goto-char link-end) (skip-chars-forward " \t")) + end (point)) + ;; Special "file" type link processing. Extract opening + ;; application and search option, if any. Also normalize URI. + (when (string-match "\\`file\\(?:\\+\\(.+\\)\\)?\\'" type) + (setq application (match-string 1 type) type "file") + (when (string-match "::\\(.*\\)\\'" path) + (setq search-option (match-string 1 path) + path (replace-match "" nil nil path))) + (setq path (replace-regexp-in-string "\\`/+" "/" path))) + (list 'link + (list :type type + :path path + :raw-link (or raw-link path) + :application application + :search-option search-option + :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-link-interpreter (link contents) "Interpret LINK object as Org syntax. @@ -3186,188 +3148,131 @@ CONTENTS is the contents of the object, or nil." raw-link (if contents (format "[%s]" contents) ""))))) -(defun org-element-link-successor () - "Search for the next link object. - -Return value is a cons cell whose CAR is `link' and CDR is -beginning position." - (save-excursion - (let ((link-regexp - (if (not org-target-link-regexp) org-any-link-re - (concat org-any-link-re "\\|" org-target-link-regexp)))) - (when (re-search-forward link-regexp nil t) - (cons 'link (match-beginning 0)))))) - -(defun org-element-plain-link-successor () - "Search for the next plain link object. - -Return value is a cons cell whose CAR is `link' and CDR is -beginning position." - (and (save-excursion (re-search-forward org-plain-link-re nil t)) - (cons 'link (match-beginning 0)))) - ;;;; Macro (defun org-element-macro-parser () - "Parse macro at point. + "Parse macro at point, if any. -Return a list whose CAR is `macro' and CDR a plist with `:key', -`:args', `:begin', `:end', `:value' and `:post-blank' as -keywords. +When at a macro, return a list whose car is `macro' and cdr +a plist with `:key', `:args', `:begin', `:end', `:value' and +`:post-blank' as keywords. Otherwise, return nil. Assume point is at the macro." (save-excursion - (looking-at "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\(([ \t\n]*\\([^\000]*?\\))\\)?}}}") - (let ((begin (point)) - (key (downcase (org-match-string-no-properties 1))) - (value (org-match-string-no-properties 0)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point)) - (args (let ((args (org-match-string-no-properties 3))) - (when args - ;; Do not use `org-split-string' since empty - ;; strings are meaningful here. - (split-string - (replace-regexp-in-string - "\\(\\\\*\\)\\(,\\)" - (lambda (str) - (let ((len (length (match-string 1 str)))) - (concat (make-string (/ len 2) ?\\) - (if (zerop (mod len 2)) "\000" ",")))) - args nil t) - "\000"))))) - (list 'macro - (list :key key - :value value - :args args - :begin begin - :end end - :post-blank post-blank))))) + (when (looking-at "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\(([ \t\n]*\\([^\000]*?\\))\\)?}}}") + (let ((begin (point)) + (key (downcase (org-match-string-no-properties 1))) + (value (org-match-string-no-properties 0)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point)) + (args (let ((args (org-match-string-no-properties 3))) + (and args (org-macro-extract-arguments args))))) + (list 'macro + (list :key key + :value value + :args args + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-macro-interpreter (macro contents) "Interpret MACRO object as Org syntax. CONTENTS is nil." (org-element-property :value macro)) -(defun org-element-macro-successor () - "Search for the next macro object. - -Return value is cons cell whose CAR is `macro' and CDR is -beginning position." - (save-excursion - (when (re-search-forward - "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\(([ \t\n]*\\([^\000]*?\\))\\)?}}}" - nil t) - (cons 'macro (match-beginning 0))))) - ;;;; Radio-target (defun org-element-radio-target-parser () - "Parse radio target at point. + "Parse radio target at point, if any. -Return a list whose CAR is `radio-target' and CDR a plist with -`:begin', `:end', `:contents-begin', `:contents-end', `:value' -and `:post-blank' as keywords. +When at a radio target, return a list whose car is `radio-target' +and cdr a plist with `:begin', `:end', `:contents-begin', +`:contents-end', `:value' and `:post-blank' as keywords. +Otherwise, return nil. Assume point is at the radio target." (save-excursion - (looking-at org-radio-target-regexp) - (let ((begin (point)) - (contents-begin (match-beginning 1)) - (contents-end (match-end 1)) - (value (org-match-string-no-properties 1)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'radio-target - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank - :value value))))) + (when (looking-at org-radio-target-regexp) + (let ((begin (point)) + (contents-begin (match-beginning 1)) + (contents-end (match-end 1)) + (value (org-match-string-no-properties 1)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'radio-target + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank + :value value)))))) (defun org-element-radio-target-interpreter (target contents) "Interpret TARGET object as Org syntax. CONTENTS is the contents of the object." (concat "<<<" contents ">>>")) -(defun org-element-radio-target-successor () - "Search for the next radio-target object. - -Return value is a cons cell whose CAR is `radio-target' and CDR -is beginning position." - (save-excursion - (when (re-search-forward org-radio-target-regexp nil t) - (cons 'radio-target (match-beginning 0))))) - ;;;; Statistics Cookie (defun org-element-statistics-cookie-parser () - "Parse statistics cookie at point. + "Parse statistics cookie at point, if any. -Return a list whose CAR is `statistics-cookie', and CDR a plist -with `:begin', `:end', `:value' and `:post-blank' keywords. +When at a statistics cookie, return a list whose car is +`statistics-cookie', and cdr a plist with `:begin', `:end', +`:value' and `:post-blank' keywords. Otherwise, return nil. Assume point is at the beginning of the statistics-cookie." (save-excursion - (looking-at "\\[[0-9]*\\(%\\|/[0-9]*\\)\\]") - (let* ((begin (point)) - (value (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'statistics-cookie - (list :begin begin - :end end - :value value - :post-blank post-blank))))) + (when (looking-at "\\[[0-9]*\\(%\\|/[0-9]*\\)\\]") + (let* ((begin (point)) + (value (buffer-substring-no-properties + (match-beginning 0) (match-end 0))) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'statistics-cookie + (list :begin begin + :end end + :value value + :post-blank post-blank)))))) (defun org-element-statistics-cookie-interpreter (statistics-cookie contents) "Interpret STATISTICS-COOKIE object as Org syntax. CONTENTS is nil." (org-element-property :value statistics-cookie)) -(defun org-element-statistics-cookie-successor () - "Search for the next statistics cookie object. - -Return value is a cons cell whose CAR is `statistics-cookie' and -CDR is beginning position." - (save-excursion - (when (re-search-forward "\\[[0-9]*\\(%\\|/[0-9]*\\)\\]" nil t) - (cons 'statistics-cookie (match-beginning 0))))) - ;;;; Strike-Through (defun org-element-strike-through-parser () - "Parse strike-through object at point. + "Parse strike-through object at point, if any. -Return a list whose CAR is `strike-through' and CDR is a plist -with `:begin', `:end', `:contents-begin' and `:contents-end' and -`:post-blank' keywords. +When at a strike-through object, return a list whose car is +`strike-through' and cdr is a plist with `:begin', `:end', +`:contents-begin' and `:contents-end' and `:post-blank' keywords. +Otherwise, return nil. Assume point is at the first plus sign marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (contents-begin (match-beginning 4)) - (contents-end (match-end 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'strike-through - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (contents-begin (match-beginning 4)) + (contents-end (match-end 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'strike-through + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-strike-through-interpreter (strike-through contents) "Interpret STRIKE-THROUGH object as Org syntax. @@ -3378,32 +3283,32 @@ CONTENTS is the contents of the object." ;;;; Subscript (defun org-element-subscript-parser () - "Parse subscript at point. + "Parse subscript at point, if any. -Return a list whose CAR is `subscript' and CDR a plist with -`:begin', `:end', `:contents-begin', `:contents-end', -`:use-brackets-p' and `:post-blank' as keywords. +When at a subscript object, return a list whose car is +`subscript' and cdr a plist with `:begin', `:end', +`:contents-begin', `:contents-end', `:use-brackets-p' and +`:post-blank' as keywords. Otherwise, return nil. Assume point is at the underscore." (save-excursion (unless (bolp) (backward-char)) - (let ((bracketsp (if (looking-at org-match-substring-with-braces-regexp) - t - (not (looking-at org-match-substring-regexp)))) - (begin (match-beginning 2)) - (contents-begin (or (match-beginning 5) - (match-beginning 3))) - (contents-end (or (match-end 5) (match-end 3))) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'subscript - (list :begin begin - :end end - :use-brackets-p bracketsp - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-match-substring-regexp) + (let ((bracketsp (match-beginning 4)) + (begin (match-beginning 2)) + (contents-begin (or (match-beginning 4) + (match-beginning 3))) + (contents-end (or (match-end 4) (match-end 3))) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'subscript + (list :begin begin + :end end + :use-brackets-p bracketsp + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-subscript-interpreter (subscript contents) "Interpret SUBSCRIPT object as Org syntax. @@ -3412,46 +3317,36 @@ CONTENTS is the contents of the object." (if (org-element-property :use-brackets-p subscript) "_{%s}" "_%s") contents)) -(defun org-element-sub/superscript-successor () - "Search for the next sub/superscript object. - -Return value is a cons cell whose CAR is either `subscript' or -`superscript' and CDR is beginning position." - (save-excursion - (unless (bolp) (backward-char)) - (when (re-search-forward org-match-substring-regexp nil t) - (cons (if (string= (match-string 2) "_") 'subscript 'superscript) - (match-beginning 2))))) - ;;;; Superscript (defun org-element-superscript-parser () - "Parse superscript at point. + "Parse superscript at point, if any. -Return a list whose CAR is `superscript' and CDR a plist with -`:begin', `:end', `:contents-begin', `:contents-end', -`:use-brackets-p' and `:post-blank' as keywords. +When at a superscript object, return a list whose car is +`superscript' and cdr a plist with `:begin', `:end', +`:contents-begin', `:contents-end', `:use-brackets-p' and +`:post-blank' as keywords. Otherwise, return nil. Assume point is at the caret." (save-excursion (unless (bolp) (backward-char)) - (let ((bracketsp (if (looking-at org-match-substring-with-braces-regexp) t - (not (looking-at org-match-substring-regexp)))) - (begin (match-beginning 2)) - (contents-begin (or (match-beginning 5) - (match-beginning 3))) - (contents-end (or (match-end 5) (match-end 3))) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'superscript - (list :begin begin - :end end - :use-brackets-p bracketsp - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-match-substring-regexp) + (let ((bracketsp (match-beginning 4)) + (begin (match-beginning 2)) + (contents-begin (or (match-beginning 4) + (match-beginning 3))) + (contents-end (or (match-end 4) (match-end 3))) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'superscript + (list :begin begin + :end end + :use-brackets-p bracketsp + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-superscript-interpreter (superscript contents) "Interpret SUPERSCRIPT object as Org syntax. @@ -3465,8 +3360,7 @@ CONTENTS is the contents of the object." (defun org-element-table-cell-parser () "Parse table cell at point. - -Return a list whose CAR is `table-cell' and CDR is a plist +Return a list whose car is `table-cell' and cdr is a plist containing `:begin', `:end', `:contents-begin', `:contents-end' and `:post-blank' keywords." (looking-at "[ \t]*\\(.*?\\)[ \t]*\\(?:|\\|$\\)") @@ -3486,291 +3380,270 @@ and `:post-blank' keywords." CONTENTS is the contents of the cell, or nil." (concat " " contents " |")) -(defun org-element-table-cell-successor () - "Search for the next table-cell object. - -Return value is a cons cell whose CAR is `table-cell' and CDR is -beginning position." - (when (looking-at "[ \t]*.*?[ \t]*\\(|\\|$\\)") (cons 'table-cell (point)))) - ;;;; Target (defun org-element-target-parser () - "Parse target at point. + "Parse target at point, if any. -Return a list whose CAR is `target' and CDR a plist with -`:begin', `:end', `:value' and `:post-blank' as keywords. +When at a target, return a list whose car is `target' and cdr +a plist with `:begin', `:end', `:value' and `:post-blank' as +keywords. Otherwise, return nil. Assume point is at the target." (save-excursion - (looking-at org-target-regexp) - (let ((begin (point)) - (value (org-match-string-no-properties 1)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'target - (list :begin begin - :end end - :value value - :post-blank post-blank))))) + (when (looking-at org-target-regexp) + (let ((begin (point)) + (value (org-match-string-no-properties 1)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'target + (list :begin begin + :end end + :value value + :post-blank post-blank)))))) (defun org-element-target-interpreter (target contents) "Interpret TARGET object as Org syntax. CONTENTS is nil." (format "<<%s>>" (org-element-property :value target))) -(defun org-element-target-successor () - "Search for the next target object. - -Return value is a cons cell whose CAR is `target' and CDR is -beginning position." - (save-excursion - (when (re-search-forward org-target-regexp nil t) - (cons 'target (match-beginning 0))))) - ;;;; Timestamp +(defconst org-element--timestamp-regexp + (concat org-ts-regexp-both + "\\|" + "\\(?:<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[dwmy]>\\)" + "\\|" + "\\(?:<%%\\(?:([^>\n]+)\\)>\\)") + "Regexp matching any timestamp type object.") + (defun org-element-timestamp-parser () - "Parse time stamp at point. + "Parse time stamp at point, if any. -Return a list whose CAR is `timestamp', and CDR a plist with -`:type', `:raw-value', `:year-start', `:month-start', -`:day-start', `:hour-start', `:minute-start', `:year-end', -`:month-end', `:day-end', `:hour-end', `:minute-end', -`:repeater-type', `:repeater-value', `:repeater-unit', -`:warning-type', `:warning-value', `:warning-unit', `:begin', -`:end' and `:post-blank' keywords. +When at a time stamp, return a list whose car is `timestamp', and +cdr a plist with `:type', `:raw-value', `:year-start', +`:month-start', `:day-start', `:hour-start', `:minute-start', +`:year-end', `:month-end', `:day-end', `:hour-end', +`:minute-end', `:repeater-type', `:repeater-value', +`:repeater-unit', `:warning-type', `:warning-value', +`:warning-unit', `:begin', `:end' and `:post-blank' keywords. +Otherwise, return nil. Assume point is at the beginning of the timestamp." - (save-excursion - (let* ((begin (point)) - (activep (eq (char-after) ?<)) - (raw-value - (progn - (looking-at "\\([<[]\\(%%\\)?.*?\\)[]>]\\(?:--\\([<[].*?[]>]\\)\\)?") - (match-string-no-properties 0))) - (date-start (match-string-no-properties 1)) - (date-end (match-string 3)) - (diaryp (match-beginning 2)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point)) - (time-range - (and (not diaryp) - (string-match - "[012]?[0-9]:[0-5][0-9]\\(-\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)" - date-start) - (cons (string-to-number (match-string 2 date-start)) - (string-to-number (match-string 3 date-start))))) - (type (cond (diaryp 'diary) - ((and activep (or date-end time-range)) 'active-range) - (activep 'active) - ((or date-end time-range) 'inactive-range) - (t 'inactive))) - (repeater-props - (and (not diaryp) - (string-match "\\([.+]?\\+\\)\\([0-9]+\\)\\([hdwmy]\\)" - raw-value) - (list - :repeater-type - (let ((type (match-string 1 raw-value))) - (cond ((equal "++" type) 'catch-up) - ((equal ".+" type) 'restart) - (t 'cumulate))) - :repeater-value (string-to-number (match-string 2 raw-value)) - :repeater-unit - (case (string-to-char (match-string 3 raw-value)) - (?h 'hour) (?d 'day) (?w 'week) (?m 'month) (t 'year))))) - (warning-props - (and (not diaryp) - (string-match "\\(-\\)?-\\([0-9]+\\)\\([hdwmy]\\)" raw-value) - (list - :warning-type (if (match-string 1 raw-value) 'first 'all) - :warning-value (string-to-number (match-string 2 raw-value)) - :warning-unit - (case (string-to-char (match-string 3 raw-value)) - (?h 'hour) (?d 'day) (?w 'week) (?m 'month) (t 'year))))) - year-start month-start day-start hour-start minute-start year-end - month-end day-end hour-end minute-end) - ;; Parse date-start. - (unless diaryp - (let ((date (org-parse-time-string date-start t))) - (setq year-start (nth 5 date) - month-start (nth 4 date) - day-start (nth 3 date) - hour-start (nth 2 date) - minute-start (nth 1 date)))) - ;; Compute date-end. It can be provided directly in time-stamp, - ;; or extracted from time range. Otherwise, it defaults to the - ;; same values as date-start. - (unless diaryp - (let ((date (and date-end (org-parse-time-string date-end t)))) - (setq year-end (or (nth 5 date) year-start) - month-end (or (nth 4 date) month-start) - day-end (or (nth 3 date) day-start) - hour-end (or (nth 2 date) (car time-range) hour-start) - minute-end (or (nth 1 date) (cdr time-range) minute-start)))) - (list 'timestamp - (nconc (list :type type - :raw-value raw-value - :year-start year-start - :month-start month-start - :day-start day-start - :hour-start hour-start - :minute-start minute-start - :year-end year-end - :month-end month-end - :day-end day-end - :hour-end hour-end - :minute-end minute-end - :begin begin - :end end - :post-blank post-blank) - repeater-props - warning-props))))) + (when (org-looking-at-p org-element--timestamp-regexp) + (save-excursion + (let* ((begin (point)) + (activep (eq (char-after) ?<)) + (raw-value + (progn + (looking-at "\\([<[]\\(%%\\)?.*?\\)[]>]\\(?:--\\([<[].*?[]>]\\)\\)?") + (match-string-no-properties 0))) + (date-start (match-string-no-properties 1)) + (date-end (match-string 3)) + (diaryp (match-beginning 2)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point)) + (time-range + (and (not diaryp) + (string-match + "[012]?[0-9]:[0-5][0-9]\\(-\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)" + date-start) + (cons (string-to-number (match-string 2 date-start)) + (string-to-number (match-string 3 date-start))))) + (type (cond (diaryp 'diary) + ((and activep (or date-end time-range)) 'active-range) + (activep 'active) + ((or date-end time-range) 'inactive-range) + (t 'inactive))) + (repeater-props + (and (not diaryp) + (string-match "\\([.+]?\\+\\)\\([0-9]+\\)\\([hdwmy]\\)" + raw-value) + (list + :repeater-type + (let ((type (match-string 1 raw-value))) + (cond ((equal "++" type) 'catch-up) + ((equal ".+" type) 'restart) + (t 'cumulate))) + :repeater-value (string-to-number (match-string 2 raw-value)) + :repeater-unit + (case (string-to-char (match-string 3 raw-value)) + (?h 'hour) (?d 'day) (?w 'week) (?m 'month) (t 'year))))) + (warning-props + (and (not diaryp) + (string-match "\\(-\\)?-\\([0-9]+\\)\\([hdwmy]\\)" raw-value) + (list + :warning-type (if (match-string 1 raw-value) 'first 'all) + :warning-value (string-to-number (match-string 2 raw-value)) + :warning-unit + (case (string-to-char (match-string 3 raw-value)) + (?h 'hour) (?d 'day) (?w 'week) (?m 'month) (t 'year))))) + year-start month-start day-start hour-start minute-start year-end + month-end day-end hour-end minute-end) + ;; Parse date-start. + (unless diaryp + (let ((date (org-parse-time-string date-start t))) + (setq year-start (nth 5 date) + month-start (nth 4 date) + day-start (nth 3 date) + hour-start (nth 2 date) + minute-start (nth 1 date)))) + ;; Compute date-end. It can be provided directly in time-stamp, + ;; or extracted from time range. Otherwise, it defaults to the + ;; same values as date-start. + (unless diaryp + (let ((date (and date-end (org-parse-time-string date-end t)))) + (setq year-end (or (nth 5 date) year-start) + month-end (or (nth 4 date) month-start) + day-end (or (nth 3 date) day-start) + hour-end (or (nth 2 date) (car time-range) hour-start) + minute-end (or (nth 1 date) (cdr time-range) minute-start)))) + (list 'timestamp + (nconc (list :type type + :raw-value raw-value + :year-start year-start + :month-start month-start + :day-start day-start + :hour-start hour-start + :minute-start minute-start + :year-end year-end + :month-end month-end + :day-end day-end + :hour-end hour-end + :minute-end minute-end + :begin begin + :end end + :post-blank post-blank) + repeater-props + warning-props)))))) (defun org-element-timestamp-interpreter (timestamp contents) "Interpret TIMESTAMP object as Org syntax. CONTENTS is nil." - ;; Use `:raw-value' if specified. - (or (org-element-property :raw-value timestamp) - ;; Otherwise, build timestamp string. - (let* ((repeat-string - (concat - (case (org-element-property :repeater-type timestamp) - (cumulate "+") (catch-up "++") (restart ".+")) - (let ((val (org-element-property :repeater-value timestamp))) - (and val (number-to-string val))) - (case (org-element-property :repeater-unit timestamp) - (hour "h") (day "d") (week "w") (month "m") (year "y")))) - (warning-string - (concat - (case (org-element-property :warning-type timestamp) - (first "--") - (all "-")) - (let ((val (org-element-property :warning-value timestamp))) - (and val (number-to-string val))) - (case (org-element-property :warning-unit timestamp) - (hour "h") (day "d") (week "w") (month "m") (year "y")))) - (build-ts-string - ;; Build an Org timestamp string from TIME. ACTIVEP is - ;; non-nil when time stamp is active. If WITH-TIME-P is - ;; non-nil, add a time part. HOUR-END and MINUTE-END - ;; specify a time range in the timestamp. REPEAT-STRING - ;; is the repeater string, if any. - (lambda (time activep &optional with-time-p hour-end minute-end) - (let ((ts (format-time-string - (funcall (if with-time-p 'cdr 'car) - org-time-stamp-formats) - time))) - (when (and hour-end minute-end) - (string-match "[012]?[0-9]:[0-5][0-9]" ts) - (setq ts - (replace-match - (format "\\&-%02d:%02d" hour-end minute-end) - nil nil ts))) - (unless activep (setq ts (format "[%s]" (substring ts 1 -1)))) - (dolist (s (list repeat-string warning-string)) - (when (org-string-nw-p s) - (setq ts (concat (substring ts 0 -1) - " " - s - (substring ts -1))))) - ;; Return value. - ts))) - (type (org-element-property :type timestamp))) - (case type - ((active inactive) - (let* ((minute-start (org-element-property :minute-start timestamp)) - (minute-end (org-element-property :minute-end timestamp)) - (hour-start (org-element-property :hour-start timestamp)) - (hour-end (org-element-property :hour-end timestamp)) - (time-range-p (and hour-start hour-end minute-start minute-end - (or (/= hour-start hour-end) - (/= minute-start minute-end))))) - (funcall - build-ts-string - (encode-time 0 - (or minute-start 0) - (or hour-start 0) - (org-element-property :day-start timestamp) - (org-element-property :month-start timestamp) - (org-element-property :year-start timestamp)) - (eq type 'active) - (and hour-start minute-start) - (and time-range-p hour-end) - (and time-range-p minute-end)))) - ((active-range inactive-range) - (let ((minute-start (org-element-property :minute-start timestamp)) - (minute-end (org-element-property :minute-end timestamp)) - (hour-start (org-element-property :hour-start timestamp)) - (hour-end (org-element-property :hour-end timestamp))) - (concat - (funcall - build-ts-string (encode-time - 0 - (or minute-start 0) - (or hour-start 0) - (org-element-property :day-start timestamp) - (org-element-property :month-start timestamp) - (org-element-property :year-start timestamp)) - (eq type 'active-range) - (and hour-start minute-start)) - "--" - (funcall build-ts-string - (encode-time 0 - (or minute-end 0) - (or hour-end 0) - (org-element-property :day-end timestamp) - (org-element-property :month-end timestamp) - (org-element-property :year-end timestamp)) - (eq type 'active-range) - (and hour-end minute-end))))))))) - -(defun org-element-timestamp-successor () - "Search for the next timestamp object. - -Return value is a cons cell whose CAR is `timestamp' and CDR is -beginning position." - (save-excursion - (when (re-search-forward - (concat org-ts-regexp-both - "\\|" - "\\(?:<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[dwmy]>\\)" - "\\|" - "\\(?:<%%\\(?:([^>\n]+)\\)>\\)") - nil t) - (cons 'timestamp (match-beginning 0))))) + (let* ((repeat-string + (concat + (case (org-element-property :repeater-type timestamp) + (cumulate "+") (catch-up "++") (restart ".+")) + (let ((val (org-element-property :repeater-value timestamp))) + (and val (number-to-string val))) + (case (org-element-property :repeater-unit timestamp) + (hour "h") (day "d") (week "w") (month "m") (year "y")))) + (warning-string + (concat + (case (org-element-property :warning-type timestamp) + (first "--") + (all "-")) + (let ((val (org-element-property :warning-value timestamp))) + (and val (number-to-string val))) + (case (org-element-property :warning-unit timestamp) + (hour "h") (day "d") (week "w") (month "m") (year "y")))) + (build-ts-string + ;; Build an Org timestamp string from TIME. ACTIVEP is + ;; non-nil when time stamp is active. If WITH-TIME-P is + ;; non-nil, add a time part. HOUR-END and MINUTE-END + ;; specify a time range in the timestamp. REPEAT-STRING is + ;; the repeater string, if any. + (lambda (time activep &optional with-time-p hour-end minute-end) + (let ((ts (format-time-string + (funcall (if with-time-p 'cdr 'car) + org-time-stamp-formats) + time))) + (when (and hour-end minute-end) + (string-match "[012]?[0-9]:[0-5][0-9]" ts) + (setq ts + (replace-match + (format "\\&-%02d:%02d" hour-end minute-end) + nil nil ts))) + (unless activep (setq ts (format "[%s]" (substring ts 1 -1)))) + (dolist (s (list repeat-string warning-string)) + (when (org-string-nw-p s) + (setq ts (concat (substring ts 0 -1) + " " + s + (substring ts -1))))) + ;; Return value. + ts))) + (type (org-element-property :type timestamp))) + (case type + ((active inactive) + (let* ((minute-start (org-element-property :minute-start timestamp)) + (minute-end (org-element-property :minute-end timestamp)) + (hour-start (org-element-property :hour-start timestamp)) + (hour-end (org-element-property :hour-end timestamp)) + (time-range-p (and hour-start hour-end minute-start minute-end + (or (/= hour-start hour-end) + (/= minute-start minute-end))))) + (funcall + build-ts-string + (encode-time 0 + (or minute-start 0) + (or hour-start 0) + (org-element-property :day-start timestamp) + (org-element-property :month-start timestamp) + (org-element-property :year-start timestamp)) + (eq type 'active) + (and hour-start minute-start) + (and time-range-p hour-end) + (and time-range-p minute-end)))) + ((active-range inactive-range) + (let ((minute-start (org-element-property :minute-start timestamp)) + (minute-end (org-element-property :minute-end timestamp)) + (hour-start (org-element-property :hour-start timestamp)) + (hour-end (org-element-property :hour-end timestamp))) + (concat + (funcall + build-ts-string (encode-time + 0 + (or minute-start 0) + (or hour-start 0) + (org-element-property :day-start timestamp) + (org-element-property :month-start timestamp) + (org-element-property :year-start timestamp)) + (eq type 'active-range) + (and hour-start minute-start)) + "--" + (funcall build-ts-string + (encode-time 0 + (or minute-end 0) + (or hour-end 0) + (org-element-property :day-end timestamp) + (org-element-property :month-end timestamp) + (org-element-property :year-end timestamp)) + (eq type 'active-range) + (and hour-end minute-end))))) + (otherwise (org-element-property :raw-value timestamp))))) ;;;; Underline (defun org-element-underline-parser () - "Parse underline object at point. + "Parse underline object at point, if any. -Return a list whose CAR is `underline' and CDR is a plist with -`:begin', `:end', `:contents-begin' and `:contents-end' and -`:post-blank' keywords. +When at an underline object, return a list whose car is +`underline' and cdr is a plist with `:begin', `:end', +`:contents-begin' and `:contents-end' and `:post-blank' keywords. +Otherwise, return nil. Assume point is at the first underscore marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (contents-begin (match-beginning 4)) - (contents-end (match-end 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'underline - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (contents-begin (match-beginning 4)) + (contents-end (match-end 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'underline + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-underline-interpreter (underline contents) "Interpret UNDERLINE object as Org syntax. @@ -3781,25 +3654,26 @@ CONTENTS is the contents of the object." ;;;; Verbatim (defun org-element-verbatim-parser () - "Parse verbatim object at point. + "Parse verbatim object at point, if any. -Return a list whose CAR is `verbatim' and CDR is a plist with -`:value', `:begin', `:end' and `:post-blank' keywords. +When at a verbatim object, return a list whose car is `verbatim' +and cdr is a plist with `:value', `:begin', `:end' and +`:post-blank' keywords. Otherwise, return nil. Assume point is at the first equal sign marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (value (org-match-string-no-properties 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'verbatim - (list :value value - :begin begin - :end end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (value (org-match-string-no-properties 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'verbatim + (list :value value + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-verbatim-interpreter (verbatim contents) "Interpret VERBATIM object as Org syntax. @@ -3818,10 +3692,9 @@ CONTENTS is nil." ;; are activated for fixed element chaining (e.g., `plain-list' > ;; `item') or fixed conditional element chaining (e.g., `headline' > ;; `section'). Special modes are: `first-section', `item', -;; `node-property', `quote-section', `section' and `table-row'. +;; `node-property', `section' and `table-row'. -(defun org-element--current-element - (limit &optional granularity special structure) +(defun org-element--current-element (limit &optional granularity mode structure) "Parse the element starting at point. Return value is a list like (TYPE PROPS) where TYPE is the type @@ -3838,12 +3711,12 @@ recursion. Allowed values are `headline', `greater-element', nil), secondary values will not be parsed, since they only contain objects. -Optional argument SPECIAL, when non-nil, can be either -`first-section', `item', `node-property', `quote-section', -`section', and `table-row'. +Optional argument MODE, when non-nil, can be either +`first-section', `section', `planning', `item', `node-property' +and `table-row'. -If STRUCTURE isn't provided but SPECIAL is set to `item', it will -be computed. +If STRUCTURE isn't provided but MODE is set to `item', it will be +computed. This function assumes point is always at the beginning of the element it has to parse." @@ -3855,30 +3728,33 @@ element it has to parse." (raw-secondary-p (and granularity (not (eq granularity 'object))))) (cond ;; Item. - ((eq special 'item) + ((eq mode 'item) (org-element-item-parser limit structure raw-secondary-p)) ;; Table Row. - ((eq special 'table-row) (org-element-table-row-parser limit)) + ((eq mode 'table-row) (org-element-table-row-parser limit)) ;; Node Property. - ((eq special 'node-property) (org-element-node-property-parser limit)) + ((eq mode 'node-property) (org-element-node-property-parser limit)) ;; Headline. ((org-with-limited-levels (org-at-heading-p)) (org-element-headline-parser limit raw-secondary-p)) ;; Sections (must be checked after headline). - ((eq special 'section) (org-element-section-parser limit)) - ((eq special 'quote-section) (org-element-quote-section-parser limit)) - ((eq special 'first-section) + ((eq mode 'section) (org-element-section-parser limit)) + ((eq mode 'first-section) (org-element-section-parser (or (save-excursion (org-with-limited-levels (outline-next-heading))) limit))) + ;; Planning. + ((and (eq mode 'planning) (looking-at org-planning-line-re)) + (org-element-planning-parser limit)) + ;; Property drawer. + ((and (memq mode '(planning property-drawer)) + (looking-at org-property-drawer-re)) + (org-element-property-drawer-parser limit)) ;; When not at bol, point is at the beginning of an item or ;; a footnote definition: next item is always a paragraph. ((not (bolp)) (org-element-paragraph-parser limit (list (point)))) - ;; Planning and Clock. - ((looking-at org-planning-or-clock-line-re) - (if (equal (match-string 1) org-clock-string) - (org-element-clock-parser limit) - (org-element-planning-parser limit))) + ;; Clock. + ((looking-at org-clock-line-re) (org-element-clock-parser limit)) ;; Inlinetask. ((org-at-heading-p) (org-element-inlinetask-parser limit raw-secondary-p)) @@ -3891,13 +3767,11 @@ element it has to parse." (goto-char (car affiliated)) (org-element-keyword-parser limit nil)) ;; LaTeX Environment. - ((looking-at "[ \t]*\\\\begin{\\([A-Za-z0-9]+\\*?\\)}\\(\\[.*?\\]\\|{.*?}\\)*[ \t]*$") + ((looking-at org-element--latex-begin-environment) (org-element-latex-environment-parser limit affiliated)) ;; Drawer and Property Drawer. ((looking-at org-drawer-regexp) - (if (equal (match-string 1) "PROPERTIES") - (org-element-property-drawer-parser limit affiliated) - (org-element-drawer-parser limit affiliated))) + (org-element-drawer-parser limit affiliated)) ;; Fixed Width ((looking-at "[ \t]*:\\( \\|$\\)") (org-element-fixed-width-parser limit affiliated)) @@ -3936,7 +3810,8 @@ element it has to parse." ((looking-at "%%(") (org-element-diary-sexp-parser limit affiliated)) ;; Table. - ((org-at-table-p t) (org-element-table-parser limit affiliated)) + ((looking-at "[ \t]*\\(|\\|\\+\\(-+\\+\\)+[ \t]*$\\)") + (org-element-table-parser limit affiliated)) ;; List. ((looking-at (org-item-re)) (org-element-plain-list-parser @@ -3980,7 +3855,7 @@ position of point and CDR is nil." (save-match-data (org-trim (buffer-substring-no-properties - (match-end 0) (point-at-eol))))) + (match-end 0) (line-end-position))))) ;; PARSEDP is non-nil when keyword should have its ;; value parsed. (parsedp (member kwd org-element-parsed-keywords)) @@ -3991,12 +3866,17 @@ position of point and CDR is nil." (and dualp (let ((sec (org-match-string-no-properties 2))) (if (or (not sec) (not parsedp)) sec - (org-element-parse-secondary-string sec restrict))))) + (org-element--parse-objects + (match-beginning 2) (match-end 2) nil restrict))))) ;; Attribute a property name to KWD. (kwd-sym (and kwd (intern (concat ":" (downcase kwd)))))) ;; Now set final shape for VALUE. (when parsedp - (setq value (org-element-parse-secondary-string value restrict))) + (setq value + (org-element--parse-objects + (match-end 0) + (progn (end-of-line) (skip-chars-backward " \t") (point)) + nil restrict))) (when dualp (setq value (and (or value dual-value) (cons value dual-value)))) (when (or (member kwd org-element-multiple-keywords) @@ -4089,23 +3969,28 @@ looked after. Optional argument PARENT, when non-nil, is the element or object containing the secondary string. It is used to set correctly -`:parent' property within the string." - (let ((local-variables (buffer-local-variables))) - (with-temp-buffer - (dolist (v local-variables) - (ignore-errors - (if (symbolp v) (makunbound v) - (org-set-local (car v) (cdr v))))) - (insert string) - (restore-buffer-modified-p nil) - (let ((secondary (org-element--parse-objects - (point-min) (point-max) nil restriction))) - (when parent - (dolist (o secondary) (org-element-put-property o :parent parent))) - secondary)))) +`:parent' property within the string. + +If STRING is the empty string or nil, return nil." + (cond + ((not string) nil) + ((equal string "") nil) + (t (let ((local-variables (buffer-local-variables))) + (with-temp-buffer + (dolist (v local-variables) + (ignore-errors + (if (symbolp v) (makunbound v) + (org-set-local (car v) (cdr v))))) + (insert string) + (restore-buffer-modified-p nil) + (let ((data (org-element--parse-objects + (point-min) (point-max) nil restriction))) + (when parent + (dolist (o data) (org-element-put-property o :parent parent))) + data)))))) (defun org-element-map - (data types fun &optional info first-match no-recursion with-affiliated) + (data types fun &optional info first-match no-recursion with-affiliated) "Map a function on selected elements or objects. DATA is a parse tree, an element, an object, a string, or a list @@ -4141,7 +4026,7 @@ Assuming TREE is a variable containing an Org buffer parse tree, the following example will return a flat list of all `src-block' and `example-block' elements in it: - \(org-element-map tree '(example-block src-block) 'identity) + \(org-element-map tree '(example-block src-block) #'identity) The following snippet will find the first headline with a level of 1 and a \"phone\" tag, and will return its beginning position: @@ -4156,7 +4041,7 @@ of 1 and a \"phone\" tag, and will return its beginning position: The next example will return a flat list of all `plain-list' type elements in TREE that are not a sub-list themselves: - \(org-element-map tree 'plain-list 'identity nil nil 'plain-list) + \(org-element-map tree 'plain-list #'identity nil nil 'plain-list) Eventually, this example will return a flat list of all `bold' type objects containing a `latex-snippet' type object, even @@ -4164,112 +4049,98 @@ looking into captions: \(org-element-map tree 'bold \(lambda (b) - \(and (org-element-map b 'latex-snippet 'identity nil t) b)) + \(and (org-element-map b 'latex-snippet #'identity nil t) b)) nil nil nil t)" ;; Ensure TYPES and NO-RECURSION are a list, even of one element. - (unless (listp types) (setq types (list types))) - (unless (listp no-recursion) (setq no-recursion (list no-recursion))) - ;; Recursion depth is determined by --CATEGORY. - (let* ((--category + (let* ((types (if (listp types) types (list types))) + (no-recursion (if (listp no-recursion) no-recursion + (list no-recursion))) + ;; Recursion depth is determined by --CATEGORY. + (--category (catch 'found - (let ((category 'greater-elements)) - (mapc (lambda (type) - (cond ((or (memq type org-element-all-objects) - (eq type 'plain-text)) - ;; If one object is found, the function - ;; has to recurse into every object. - (throw 'found 'objects)) - ((not (memq type org-element-greater-elements)) - ;; If one regular element is found, the - ;; function has to recurse, at least, - ;; into every element it encounters. - (and (not (eq category 'elements)) - (setq category 'elements))))) - types) - category))) - ;; Compute properties for affiliated keywords if necessary. - (--affiliated-alist - (and with-affiliated - (mapcar (lambda (kwd) - (cons kwd (intern (concat ":" (downcase kwd))))) - org-element-affiliated-keywords))) + (let ((category 'greater-elements) + (all-objects (cons 'plain-text org-element-all-objects))) + (dolist (type types category) + (cond ((memq type all-objects) + ;; If one object is found, the function has to + ;; recurse into every object. + (throw 'found 'objects)) + ((not (memq type org-element-greater-elements)) + ;; If one regular element is found, the + ;; function has to recurse, at least, into + ;; every element it encounters. + (and (not (eq category 'elements)) + (setq category 'elements)))))))) --acc --walk-tree (--walk-tree - (function - (lambda (--data) - ;; Recursively walk DATA. INFO, if non-nil, is a plist - ;; holding contextual information. - (let ((--type (org-element-type --data))) - (cond - ((not --data)) - ;; Ignored element in an export context. - ((and info (memq --data (plist-get info :ignore-list)))) - ;; List of elements or objects. - ((not --type) (mapc --walk-tree --data)) - ;; Unconditionally enter parse trees. - ((eq --type 'org-data) - (mapc --walk-tree (org-element-contents --data))) - (t - ;; Check if TYPE is matching among TYPES. If so, - ;; apply FUN to --DATA and accumulate return value - ;; into --ACC (or exit if FIRST-MATCH is non-nil). - (when (memq --type types) - (let ((result (funcall fun --data))) - (cond ((not result)) - (first-match (throw '--map-first-match result)) - (t (push result --acc))))) - ;; If --DATA has a secondary string that can contain - ;; objects with their type among TYPES, look into it. - (when (and (eq --category 'objects) (not (stringp --data))) - (let ((sec-prop - (assq --type org-element-secondary-value-alist))) - (when sec-prop - (funcall --walk-tree - (org-element-property (cdr sec-prop) --data))))) - ;; If --DATA has any affiliated keywords and - ;; WITH-AFFILIATED is non-nil, look for objects in - ;; them. - (when (and with-affiliated - (eq --category 'objects) - (memq --type org-element-all-elements)) - (mapc (lambda (kwd-pair) - (let ((kwd (car kwd-pair)) - (value (org-element-property - (cdr kwd-pair) --data))) - ;; Pay attention to the type of value. - ;; Preserve order for multiple keywords. - (cond - ((not value)) - ((and (member kwd org-element-multiple-keywords) - (member kwd org-element-dual-keywords)) - (mapc (lambda (line) - (funcall --walk-tree (cdr line)) - (funcall --walk-tree (car line))) - (reverse value))) - ((member kwd org-element-multiple-keywords) - (mapc (lambda (line) (funcall --walk-tree line)) - (reverse value))) - ((member kwd org-element-dual-keywords) - (funcall --walk-tree (cdr value)) - (funcall --walk-tree (car value))) - (t (funcall --walk-tree value))))) - --affiliated-alist)) - ;; Determine if a recursion into --DATA is possible. - (cond - ;; --TYPE is explicitly removed from recursion. - ((memq --type no-recursion)) - ;; --DATA has no contents. - ((not (org-element-contents --data))) - ;; Looking for greater elements but --DATA is simply - ;; an element or an object. - ((and (eq --category 'greater-elements) - (not (memq --type org-element-greater-elements)))) - ;; Looking for elements but --DATA is an object. - ((and (eq --category 'elements) - (memq --type org-element-all-objects))) - ;; In any other case, map contents. - (t (mapc --walk-tree (org-element-contents --data))))))))))) + (lambda (--data) + ;; Recursively walk DATA. INFO, if non-nil, is a plist + ;; holding contextual information. + (let ((--type (org-element-type --data))) + (cond + ((not --data)) + ;; Ignored element in an export context. + ((and info (memq --data (plist-get info :ignore-list)))) + ;; List of elements or objects. + ((not --type) (mapc --walk-tree --data)) + ;; Unconditionally enter parse trees. + ((eq --type 'org-data) + (mapc --walk-tree (org-element-contents --data))) + (t + ;; Check if TYPE is matching among TYPES. If so, + ;; apply FUN to --DATA and accumulate return value + ;; into --ACC (or exit if FIRST-MATCH is non-nil). + (when (memq --type types) + (let ((result (funcall fun --data))) + (cond ((not result)) + (first-match (throw '--map-first-match result)) + (t (push result --acc))))) + ;; If --DATA has a secondary string that can contain + ;; objects with their type among TYPES, look into it. + (when (and (eq --category 'objects) (not (stringp --data))) + (dolist (p (cdr (assq --type + org-element-secondary-value-alist))) + (funcall --walk-tree (org-element-property p --data)))) + ;; If --DATA has any parsed affiliated keywords and + ;; WITH-AFFILIATED is non-nil, look for objects in + ;; them. + (when (and with-affiliated + (eq --category 'objects) + (memq --type org-element-all-elements)) + (dolist (kwd-pair org-element--parsed-properties-alist) + (let ((kwd (car kwd-pair)) + (value (org-element-property (cdr kwd-pair) --data))) + ;; Pay attention to the type of parsed keyword. + ;; In particular, preserve order for multiple + ;; keywords. + (cond + ((not value)) + ((member kwd org-element-dual-keywords) + (if (member kwd org-element-multiple-keywords) + (dolist (line (reverse value)) + (funcall --walk-tree (cdr line)) + (funcall --walk-tree (car line))) + (funcall --walk-tree (cdr value)) + (funcall --walk-tree (car value)))) + ((member kwd org-element-multiple-keywords) + (mapc --walk-tree (reverse value))) + (t (funcall --walk-tree value)))))) + ;; Determine if a recursion into --DATA is possible. + (cond + ;; --TYPE is explicitly removed from recursion. + ((memq --type no-recursion)) + ;; --DATA has no contents. + ((not (org-element-contents --data))) + ;; Looking for greater elements but --DATA is simply + ;; an element or an object. + ((and (eq --category 'greater-elements) + (not (memq --type org-element-greater-elements)))) + ;; Looking for elements but --DATA is an object. + ((and (eq --category 'elements) + (memq --type org-element-all-objects))) + ;; In any other case, map contents. + (t (mapc --walk-tree (org-element-contents --data)))))))))) (catch '--map-first-match (funcall --walk-tree data) ;; Return value in a proper order. @@ -4282,24 +4153,37 @@ looking into captions: ;; level. ;; ;; The second one, `org-element--parse-objects' applies on all objects -;; of a paragraph or a secondary string. It uses -;; `org-element--get-next-object-candidates' to optimize the search of -;; the next object in the buffer. -;; -;; More precisely, that function looks for every allowed object type -;; first. Then, it discards failed searches, keeps further matches, -;; and searches again types matched behind point, for subsequent -;; calls. Thus, searching for a given type fails only once, and every -;; object is searched only once at top level (but sometimes more for -;; nested types). +;; of a paragraph or a secondary string. It calls +;; `org-element--object-lex' to find the next object in the current +;; container. + +(defsubst org-element--next-mode (type parentp) + "Return next special mode according to TYPE, or nil. +TYPE is a symbol representing the type of an element or object +containing next element if PARENTP is non-nil, or before it +otherwise. Modes can be either `first-section', `item', +`node-property', `planning', `property-drawer', `section', +`table-row' or nil." + (if parentp + (case type + (headline 'section) + (plain-list 'item) + (property-drawer 'node-property) + (section 'planning) + (table 'table-row)) + (case type + (item 'item) + (node-property 'node-property) + (planning 'property-drawer) + (table-row 'table-row)))) (defun org-element--parse-elements - (beg end special structure granularity visible-only acc) + (beg end mode structure granularity visible-only acc) "Parse elements between BEG and END positions. -SPECIAL prioritize some elements over the others. It can be set -to `first-section', `quote-section', `section' `item' or -`table-row'. +MODE prioritizes some elements over the others. It can be set to +`first-section', `section', `planning', `item', `node-property' +or `table-row'. When value is `item', STRUCTURE will be used as the current list structure. @@ -4325,7 +4209,7 @@ Elements are accumulated into ACC." ;; Find current element's type and parse it accordingly to ;; its category. (let* ((element (org-element--current-element - end granularity special structure)) + end granularity mode structure)) (type (org-element-type element)) (cbeg (org-element-property :contents-begin element))) (goto-char (org-element-property :end element)) @@ -4348,13 +4232,7 @@ Elements are accumulated into ACC." (org-element--parse-elements cbeg (org-element-property :contents-end element) ;; Possibly switch to a special mode. - (case type - (headline - (if (org-element-property :quotedp element) 'quote-section - 'section)) - (plain-list 'item) - (property-drawer 'node-property) - (table 'table-row)) + (org-element--next-mode type t) (and (memq type '(item plain-list)) (org-element-property :structure element)) granularity visible-only element)) @@ -4364,10 +4242,99 @@ Elements are accumulated into ACC." (org-element--parse-objects cbeg (org-element-property :contents-end element) element (org-element-restriction type)))) - (org-element-adopt-elements acc element))) + (org-element-adopt-elements acc element) + ;; Update mode. + (setq mode (org-element--next-mode type nil)))) ;; Return result. acc)) +(defun org-element--object-lex (restriction) + "Return next object in current buffer or nil. +RESTRICTION is a list of object types, as symbols, that should be +looked after. This function assumes that the buffer is narrowed +to an appropriate container (e.g., a paragraph)." + (if (memq 'table-cell restriction) (org-element-table-cell-parser) + (save-excursion + (let ((limit (and org-target-link-regexp + (save-excursion + (or (bolp) (backward-char)) + (re-search-forward org-target-link-regexp nil t)) + (match-beginning 1))) + found) + (while (and (not found) + (re-search-forward org-element--object-regexp limit t)) + (goto-char (match-beginning 0)) + (let ((result (match-string 0))) + (setq found + (cond + ((eq (compare-strings result nil nil "call_" nil nil t) t) + (and (memq 'inline-babel-call restriction) + (org-element-inline-babel-call-parser))) + ((eq (compare-strings result nil nil "src_" nil nil t) t) + (and (memq 'inline-src-block restriction) + (org-element-inline-src-block-parser))) + (t + (case (char-after) + (?^ (and (memq 'superscript restriction) + (org-element-superscript-parser))) + (?_ (or (and (memq 'subscript restriction) + (org-element-subscript-parser)) + (and (memq 'underline restriction) + (org-element-underline-parser)))) + (?* (and (memq 'bold restriction) + (org-element-bold-parser))) + (?/ (and (memq 'italic restriction) + (org-element-italic-parser))) + (?~ (and (memq 'code restriction) + (org-element-code-parser))) + (?= (and (memq 'verbatim restriction) + (org-element-verbatim-parser))) + (?+ (and (memq 'strike-through restriction) + (org-element-strike-through-parser))) + (?@ (and (memq 'export-snippet restriction) + (org-element-export-snippet-parser))) + (?{ (and (memq 'macro restriction) + (org-element-macro-parser))) + (?$ (and (memq 'latex-fragment restriction) + (org-element-latex-fragment-parser))) + (?< + (if (eq (aref result 1) ?<) + (or (and (memq 'radio-target restriction) + (org-element-radio-target-parser)) + (and (memq 'target restriction) + (org-element-target-parser))) + (or (and (memq 'timestamp restriction) + (org-element-timestamp-parser)) + (and (memq 'link restriction) + (org-element-link-parser))))) + (?\\ + (if (eq (aref result 1) ?\\) + (and (memq 'line-break restriction) + (org-element-line-break-parser)) + (or (and (memq 'entity restriction) + (org-element-entity-parser)) + (and (memq 'latex-fragment restriction) + (org-element-latex-fragment-parser))))) + (?\[ + (if (eq (aref result 1) ?\[) + (and (memq 'link restriction) + (org-element-link-parser)) + (or (and (memq 'footnote-reference restriction) + (org-element-footnote-reference-parser)) + (and (memq 'timestamp restriction) + (org-element-timestamp-parser)) + (and (memq 'statistics-cookie restriction) + (org-element-statistics-cookie-parser))))) + ;; This is probably a plain link. + (otherwise (and (or (memq 'link restriction) + (memq 'plain-link restriction)) + (org-element-link-parser))))))) + (or (eobp) (forward-char)))) + (cond (found) + ;; Radio link. + ((and limit (memq 'link restriction)) + (goto-char limit) (org-element-link-parser))))))) + (defun org-element--parse-objects (beg end acc restriction) "Parse objects between BEG and END and return recursive structure. @@ -4375,85 +4342,44 @@ Objects are accumulated in ACC. RESTRICTION is a list of object successors which are allowed in the current object." - (let ((candidates 'initial)) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (let (next-object) (while (and (not (eobp)) - (setq candidates - (org-element--get-next-object-candidates - restriction candidates))) - (let ((next-object - (let ((pos (apply 'min (mapcar 'cdr candidates)))) - (save-excursion - (goto-char pos) - (funcall (intern (format "org-element-%s-parser" - (car (rassq pos candidates))))))))) - ;; 1. Text before any object. Untabify it. - (let ((obj-beg (org-element-property :begin next-object))) - (unless (= (point) obj-beg) - (setq acc - (org-element-adopt-elements - acc - (replace-regexp-in-string - "\t" (make-string tab-width ? ) - (buffer-substring-no-properties (point) obj-beg)))))) - ;; 2. Object... - (let ((obj-end (org-element-property :end next-object)) - (cont-beg (org-element-property :contents-begin next-object))) - ;; Fill contents of NEXT-OBJECT by side-effect, if it has - ;; a recursive type. - (when (and cont-beg - (memq (car next-object) org-element-recursive-objects)) - (org-element--parse-objects - cont-beg (org-element-property :contents-end next-object) - next-object (org-element-restriction next-object))) - (setq acc (org-element-adopt-elements acc next-object)) - (goto-char obj-end)))) - ;; 3. Text after last object. Untabify it. - (unless (eobp) - (setq acc - (org-element-adopt-elements - acc - (replace-regexp-in-string - "\t" (make-string tab-width ? ) - (buffer-substring-no-properties (point) end))))) - ;; Result. - acc)))) - -(defun org-element--get-next-object-candidates (restriction objects) - "Return an alist of candidates for the next object. - -RESTRICTION is a list of object types, as symbols. Only -candidates with such types are looked after. - -OBJECTS is the previous candidates alist. If it is set to -`initial', no search has been done before, and all symbols in -RESTRICTION should be looked after. - -Return value is an alist whose CAR is the object type and CDR its -beginning position." - (delq - nil - (if (eq objects 'initial) - ;; When searching for the first time, look for every successor - ;; allowed in RESTRICTION. - (mapcar - (lambda (res) - (funcall (intern (format "org-element-%s-successor" res)))) - restriction) - ;; Focus on objects returned during last search. Keep those - ;; still after point. Search again objects before it. - (mapcar - (lambda (obj) - (if (>= (cdr obj) (point)) obj - (let* ((type (car obj)) - (succ (or (cdr (assq type org-element-object-successor-alist)) - type))) - (and succ - (funcall (intern (format "org-element-%s-successor" succ))))))) - objects)))) + (setq next-object (org-element--object-lex restriction))) + ;; 1. Text before any object. Untabify it. + (let ((obj-beg (org-element-property :begin next-object))) + (unless (= (point) obj-beg) + (setq acc + (org-element-adopt-elements + acc + (replace-regexp-in-string + "\t" (make-string tab-width ? ) + (buffer-substring-no-properties (point) obj-beg)))))) + ;; 2. Object... + (let ((obj-end (org-element-property :end next-object)) + (cont-beg (org-element-property :contents-begin next-object))) + ;; Fill contents of NEXT-OBJECT by side-effect, if it has + ;; a recursive type. + (when (and cont-beg + (memq (car next-object) org-element-recursive-objects)) + (org-element--parse-objects + cont-beg (org-element-property :contents-end next-object) + next-object (org-element-restriction next-object))) + (setq acc (org-element-adopt-elements acc next-object)) + (goto-char obj-end)))) + ;; 3. Text after last object. Untabify it. + (unless (eobp) + (setq acc + (org-element-adopt-elements + acc + (replace-regexp-in-string + "\t" (make-string tab-width ? ) + (buffer-substring-no-properties (point) end))))) + ;; Result. + acc))) @@ -4468,71 +4394,77 @@ beginning position." ;; `org-element--interpret-affiliated-keywords'. ;;;###autoload -(defun org-element-interpret-data (data &optional parent) +(defun org-element-interpret-data (data) "Interpret DATA as Org syntax. - DATA is a parse tree, an element, an object or a secondary string -to interpret. +to interpret. Return Org syntax as a string." + (org-element--interpret-data-1 data nil)) -Optional argument PARENT is used for recursive calls. It contains +(defun org-element--interpret-data-1 (data parent) + "Interpret DATA as Org syntax. + +DATA is a parse tree, an element, an object or a secondary string +to interpret. PARENT is used for recursive calls. It contains the element or object containing data, or nil. Return Org syntax as a string." (let* ((type (org-element-type data)) + ;; Find interpreter for current object or element. If it + ;; doesn't exist (e.g. this is a pseudo object or element), + ;; return contents, if any. + (interpret + (let ((fun (intern (format "org-element-%s-interpreter" type)))) + (if (fboundp fun) fun (lambda (data contents) contents)))) (results (cond ;; Secondary string. ((not type) (mapconcat - (lambda (obj) (org-element-interpret-data obj parent)) - data "")) + (lambda (obj) (org-element--interpret-data-1 obj parent)) data "")) ;; Full Org document. ((eq type 'org-data) - (mapconcat - (lambda (obj) (org-element-interpret-data obj parent)) - (org-element-contents data) "")) + (mapconcat (lambda (obj) (org-element--interpret-data-1 obj parent)) + (org-element-contents data) "")) ;; Plain text: return it. ((stringp data) data) - ;; Element/Object without contents. - ((not (org-element-contents data)) - (funcall (intern (format "org-element-%s-interpreter" type)) - data nil)) - ;; Element/Object with contents. + ;; Element or object without contents. + ((not (org-element-contents data)) (funcall interpret data nil)) + ;; Element or object with contents. (t - (let* ((greaterp (memq type org-element-greater-elements)) - (objectp (and (not greaterp) - (memq type org-element-recursive-objects))) - (contents - (mapconcat - (lambda (obj) (org-element-interpret-data obj data)) - (org-element-contents - (if (or greaterp objectp) data - ;; Elements directly containing objects must - ;; have their indentation normalized first. - (org-element-normalize-contents - data - ;; When normalizing first paragraph of an - ;; item or a footnote-definition, ignore - ;; first line's indentation. - (and (eq type 'paragraph) - (equal data (car (org-element-contents parent))) - (memq (org-element-type parent) - '(footnote-definition item)))))) - ""))) - (funcall (intern (format "org-element-%s-interpreter" type)) - data - (if greaterp (org-element-normalize-contents contents) - contents))))))) + (funcall interpret data + ;; Recursively interpret contents. + (mapconcat + (lambda (obj) (org-element--interpret-data-1 obj data)) + (org-element-contents + (if (not (memq type '(paragraph verse-block))) + data + ;; Fix indentation of elements containing + ;; objects. We ignore `table-row' elements + ;; as they are one line long anyway. + (org-element-normalize-contents + data + ;; When normalizing first paragraph of an + ;; item or a footnote-definition, ignore + ;; first line's indentation. + (and (eq type 'paragraph) + (equal data (car (org-element-contents parent))) + (memq (org-element-type parent) + '(footnote-definition item)))))) + "")))))) (if (memq type '(org-data plain-text nil)) results ;; Build white spaces. If no `:post-blank' property is ;; specified, assume its value is 0. (let ((post-blank (or (org-element-property :post-blank data) 0))) - (if (memq type org-element-all-objects) - (concat results (make-string post-blank 32)) + (if (or (memq type org-element-all-objects) + (and parent + (let ((type (org-element-type parent))) + (or (not type) + (memq type org-element-object-containers))))) + (concat results (make-string post-blank ?\s)) (concat (org-element--interpret-affiliated-keywords data) (org-element-normalize-string results) - (make-string post-blank 10))))))) + (make-string post-blank ?\n))))))) (defun org-element--interpret-affiliated-keywords (element) "Return ELEMENT's affiliated keywords as Org syntax. @@ -4616,25 +4548,29 @@ indentation is not done with TAB characters." (find-min-ind ;; Return minimal common indentation within BLOB. This is ;; done by walking recursively BLOB and updating MIN-IND - ;; along the way. FIRST-FLAG is non-nil when the first - ;; string hasn't been seen yet. It is required as this - ;; string is the only one whose indentation doesn't happen - ;; after a newline character. + ;; along the way. FIRST-FLAG is non-nil when the next + ;; object is expected to be a string that doesn't start with + ;; a newline character. It happens for strings at the + ;; beginnings of the contents or right after a line break. (lambda (blob first-flag) (dolist (object (org-element-contents blob)) - (when (and first-flag (stringp object)) + (when first-flag (setq first-flag nil) - (string-match "\\` *" object) - (let ((len (match-end 0))) - ;; An indentation of zero means no string will be - ;; modified. Quit the process. - (if (zerop len) (throw 'zero (setq min-ind 0)) - (setq min-ind (min len min-ind))))) + ;; Objects cannot start with spaces: in this case, + ;; indentation is 0. + (if (not (stringp object)) (throw 'zero (setq min-ind 0)) + (string-match "\\` *" object) + (let ((len (match-end 0))) + ;; An indentation of zero means no string will be + ;; modified. Quit the process. + (if (zerop len) (throw 'zero (setq min-ind 0)) + (setq min-ind (min len min-ind)))))) (cond ((stringp object) (dolist (line (cdr (org-split-string object " *\n"))) (unless (string= line "") (setq min-ind (min (org-get-indentation line) min-ind))))) + ((eq (org-element-type object) 'line-break) (setq first-flag t)) ((memq (org-element-type object) org-element-recursive-objects) (funcall find-min-ind object first-flag))))))) ;; Find minimal indentation in ELEMENT. @@ -4644,41 +4580,1056 @@ indentation is not done with TAB characters." ;; string minus common indentation. (let* (build ; For byte compiler. (build - (function - (lambda (blob first-flag) - ;; Return BLOB with all its strings indentation - ;; shortened from MIN-IND white spaces. FIRST-FLAG - ;; is non-nil when the first string hasn't been seen - ;; yet. - (setcdr (cdr blob) - (mapcar - #'(lambda (object) - (when (and first-flag (stringp object)) - (setq first-flag nil) - (setq object - (replace-regexp-in-string - (format "\\` \\{%d\\}" min-ind) - "" object))) - (cond - ((stringp object) - (replace-regexp-in-string - (format "\n \\{%d\\}" min-ind) "\n" object)) - ((memq (org-element-type object) - org-element-recursive-objects) - (funcall build object first-flag)) - (t object))) - (org-element-contents blob))) - blob)))) + (lambda (blob first-flag) + ;; Return BLOB with all its strings indentation + ;; shortened from MIN-IND white spaces. FIRST-FLAG is + ;; non-nil when the next object is expected to be + ;; a string that doesn't start with a newline + ;; character. + (setcdr (cdr blob) + (mapcar + (lambda (object) + (when first-flag + (setq first-flag nil) + (when (stringp object) + (setq object + (replace-regexp-in-string + (format "\\` \\{%d\\}" min-ind) + "" object)))) + (cond + ((stringp object) + (replace-regexp-in-string + (format "\n \\{%d\\}" min-ind) "\n" object)) + ((memq (org-element-type object) + org-element-recursive-objects) + (funcall build object first-flag)) + ((eq (org-element-type object) 'line-break) + (setq first-flag t) + object) + (t object))) + (org-element-contents blob))) + blob))) (funcall build element (not ignore-first)))))) +;;; Cache +;; +;; Implement a caching mechanism for `org-element-at-point' and +;; `org-element-context', which see. +;; +;; A single public function is provided: `org-element-cache-reset'. +;; +;; Cache is enabled by default, but can be disabled globally with +;; `org-element-use-cache'. `org-element-cache-sync-idle-time', +;; org-element-cache-sync-duration' and `org-element-cache-sync-break' +;; can be tweaked to control caching behaviour. +;; +;; Internally, parsed elements are stored in an AVL tree, +;; `org-element--cache'. This tree is updated lazily: whenever +;; a change happens to the buffer, a synchronization request is +;; registered in `org-element--cache-sync-requests' (see +;; `org-element--cache-submit-request'). During idle time, requests +;; are processed by `org-element--cache-sync'. Synchronization also +;; happens when an element is required from the cache. In this case, +;; the process stops as soon as the needed element is up-to-date. +;; +;; A synchronization request can only apply on a synchronized part of +;; the cache. Therefore, the cache is updated at least to the +;; location where the new request applies. Thus, requests are ordered +;; from left to right and all elements starting before the first +;; request are correct. This property is used by functions like +;; `org-element--cache-find' to retrieve elements in the part of the +;; cache that can be trusted. +;; +;; A request applies to every element, starting from its original +;; location (or key, see below). When a request is processed, it +;; moves forward and may collide the next one. In this case, both +;; requests are merged into a new one that starts from that element. +;; As a consequence, the whole synchronization complexity does not +;; depend on the number of pending requests, but on the number of +;; elements the very first request will be applied on. +;; +;; Elements cannot be accessed through their beginning position, which +;; may or may not be up-to-date. Instead, each element in the tree is +;; associated to a key, obtained with `org-element--cache-key'. This +;; mechanism is robust enough to preserve total order among elements +;; even when the tree is only partially synchronized. +;; +;; Objects contained in an element are stored in a hash table, +;; `org-element--cache-objects'. + + +(defvar org-element-use-cache t + "Non nil when Org parser should cache its results. +This is mostly for debugging purpose.") + +(defvar org-element-cache-sync-idle-time 0.6 + "Length, in seconds, of idle time before syncing cache.") + +(defvar org-element-cache-sync-duration (seconds-to-time 0.04) + "Maximum duration, as a time value, for a cache synchronization. +If the synchronization is not over after this delay, the process +pauses and resumes after `org-element-cache-sync-break' +seconds.") + +(defvar org-element-cache-sync-break (seconds-to-time 0.3) + "Duration, as a time value, of the pause between synchronizations. +See `org-element-cache-sync-duration' for more information.") + + +;;;; Data Structure + +(defvar org-element--cache nil + "AVL tree used to cache elements. +Each node of the tree contains an element. Comparison is done +with `org-element--cache-compare'. This cache is used in +`org-element-at-point'.") + +(defvar org-element--cache-objects nil + "Hash table used as to cache objects. +Key is an element, as returned by `org-element-at-point', and +value is an alist where each association is: + + \(PARENT COMPLETEP . OBJECTS) + +where PARENT is an element or object, COMPLETEP is a boolean, +non-nil when all direct children of parent are already cached and +OBJECTS is a list of such children, as objects, from farthest to +closest. + +In the following example, \\alpha, bold object and \\beta are +contained within a paragraph + + \\alpha *\\beta* + +If the paragraph is completely parsed, OBJECTS-DATA will be + + \((PARAGRAPH t BOLD-OBJECT ENTITY-OBJECT) + \(BOLD-OBJECT t ENTITY-OBJECT)) + +whereas in a partially parsed paragraph, it could be + + \((PARAGRAPH nil ENTITY-OBJECT)) + +This cache is used in `org-element-context'.") + +(defvar org-element--cache-sync-requests nil + "List of pending synchronization requests. + +A request is a vector with the following pattern: + + \[NEXT BEG END OFFSET PARENT PHASE] + +Processing a synchronization request consists of three phases: + + 0. Delete modified elements, + 1. Fill missing area in cache, + 2. Shift positions and re-parent elements after the changes. + +During phase 0, NEXT is the key of the first element to be +removed, BEG and END is buffer position delimiting the +modifications. Elements starting between them (inclusive) are +removed. So are elements whose parent is removed. PARENT, when +non-nil, is the parent of the first element to be removed. + +During phase 1, NEXT is the key of the next known element in +cache and BEG its beginning position. Parse buffer between that +element and the one before it in order to determine the parent of +the next element. Set PARENT to the element containing NEXT. + +During phase 2, NEXT is the key of the next element to shift in +the parse tree. All elements starting from this one have their +properties relatives to buffer positions shifted by integer +OFFSET and, if they belong to element PARENT, are adopted by it. + +PHASE specifies the phase number, as an integer.") + +(defvar org-element--cache-sync-timer nil + "Timer used for cache synchronization.") + +(defvar org-element--cache-sync-keys nil + "Hash table used to store keys during synchronization. +See `org-element--cache-key' for more information.") + +(defsubst org-element--cache-key (element) + "Return a unique key for ELEMENT in cache tree. + +Keys are used to keep a total order among elements in the cache. +Comparison is done with `org-element--cache-key-less-p'. + +When no synchronization is taking place, a key is simply the +beginning position of the element, or that position plus one in +the case of an first item (respectively row) in +a list (respectively a table). + +During a synchronization, the key is the one the element had when +the cache was synchronized for the last time. Elements added to +cache during the synchronization get a new key generated with +`org-element--cache-generate-key'. + +Such keys are stored in `org-element--cache-sync-keys'. The hash +table is cleared once the synchronization is complete." + (or (gethash element org-element--cache-sync-keys) + (let* ((begin (org-element-property :begin element)) + ;; Increase beginning position of items (respectively + ;; table rows) by one, so the first item can get + ;; a different key from its parent list (respectively + ;; table). + (key (if (memq (org-element-type element) '(item table-row)) + (1+ begin) + begin))) + (if org-element--cache-sync-requests + (puthash element key org-element--cache-sync-keys) + key)))) + +(defun org-element--cache-generate-key (lower upper) + "Generate a key between LOWER and UPPER. + +LOWER and UPPER are integers or lists, possibly empty. + +If LOWER and UPPER are equals, return LOWER. Otherwise, return +a unique key, as an integer or a list of integers, according to +the following rules: + + - LOWER and UPPER are compared level-wise until values differ. + + - If, at a given level, LOWER and UPPER differ from more than + 2, the new key shares all the levels above with LOWER and + gets a new level. Its value is the mean between LOWER and + UPPER: + + \(1 2) + (1 4) --> (1 3) + + - If LOWER has no value to compare with, it is assumed that its + value is `most-negative-fixnum'. E.g., + + \(1 1) + (1 1 2) + + is equivalent to + + \(1 1 m) + (1 1 2) + + where m is `most-negative-fixnum'. Likewise, if UPPER is + short of levels, the current value is `most-positive-fixnum'. + + - If they differ from only one, the new key inherits from + current LOWER level and fork it at the next level. E.g., + + \(2 1) + (3 3) + + is equivalent to + + \(2 1) + (2 M) + + where M is `most-positive-fixnum'. + + - If the key is only one level long, it is returned as an + integer: + + \(1 2) + (3 2) --> 2 + +When they are not equals, the function assumes that LOWER is +lesser than UPPER, per `org-element--cache-key-less-p'." + (if (equal lower upper) lower + (let ((lower (if (integerp lower) (list lower) lower)) + (upper (if (integerp upper) (list upper) upper)) + skip-upper key) + (catch 'exit + (while t + (let ((min (or (car lower) most-negative-fixnum)) + (max (cond (skip-upper most-positive-fixnum) + ((car upper)) + (t most-positive-fixnum)))) + (if (< (1+ min) max) + (let ((mean (+ (ash min -1) (ash max -1) (logand min max 1)))) + (throw 'exit (if key (nreverse (cons mean key)) mean))) + (when (and (< min max) (not skip-upper)) + ;; When at a given level, LOWER and UPPER differ from + ;; 1, ignore UPPER altogether. Instead create a key + ;; between LOWER and the greatest key with the same + ;; prefix as LOWER so far. + (setq skip-upper t)) + (push min key) + (setq lower (cdr lower) upper (cdr upper))))))))) + +(defsubst org-element--cache-key-less-p (a b) + "Non-nil if key A is less than key B. +A and B are either integers or lists of integers, as returned by +`org-element--cache-key'." + (if (integerp a) (if (integerp b) (< a b) (<= a (car b))) + (if (integerp b) (< (car a) b) + (catch 'exit + (while (and a b) + (cond ((car-less-than-car a b) (throw 'exit t)) + ((car-less-than-car b a) (throw 'exit nil)) + (t (setq a (cdr a) b (cdr b))))) + ;; If A is empty, either keys are equal (B is also empty) and + ;; we return nil, or A is lesser than B (B is longer) and we + ;; return a non-nil value. + ;; + ;; If A is not empty, B is necessarily empty and A is greater + ;; than B (A is longer). Therefore, return nil. + (and (null a) b))))) + +(defun org-element--cache-compare (a b) + "Non-nil when element A is located before element B." + (org-element--cache-key-less-p (org-element--cache-key a) + (org-element--cache-key b))) + +(defsubst org-element--cache-root () + "Return root value in cache. +This function assumes `org-element--cache' is a valid AVL tree." + (avl-tree--node-left (avl-tree--dummyroot org-element--cache))) + + +;;;; Tools + +(defsubst org-element--cache-active-p () + "Non-nil when cache is active in current buffer." + (and org-element-use-cache + (or (derived-mode-p 'org-mode) orgstruct-mode))) + +(defun org-element--cache-find (pos &optional side) + "Find element in cache starting at POS or before. + +POS refers to a buffer position. + +When optional argument SIDE is non-nil, the function checks for +elements starting at or past POS instead. If SIDE is `both', the +function returns a cons cell where car is the first element +starting at or before POS and cdr the first element starting +after POS. + +The function can only find elements in the synchronized part of +the cache." + (let ((limit (and org-element--cache-sync-requests + (aref (car org-element--cache-sync-requests) 0))) + (node (org-element--cache-root)) + lower upper) + (while node + (let* ((element (avl-tree--node-data node)) + (begin (org-element-property :begin element))) + (cond + ((and limit + (not (org-element--cache-key-less-p + (org-element--cache-key element) limit))) + (setq node (avl-tree--node-left node))) + ((> begin pos) + (setq upper element + node (avl-tree--node-left node))) + ((< begin pos) + (setq lower element + node (avl-tree--node-right node))) + ;; We found an element in cache starting at POS. If `side' + ;; is `both' we also want the next one in order to generate + ;; a key in-between. + ;; + ;; If the element is the first row or item in a table or + ;; a plain list, we always return the table or the plain + ;; list. + ;; + ;; In any other case, we return the element found. + ((eq side 'both) + (setq lower element) + (setq node (avl-tree--node-right node))) + ((and (memq (org-element-type element) '(item table-row)) + (let ((parent (org-element-property :parent element))) + (and (= (org-element-property :begin element) + (org-element-property :contents-begin parent)) + (setq node nil + lower parent + upper parent))))) + (t + (setq node nil + lower element + upper element))))) + (case side + (both (cons lower upper)) + ((nil) lower) + (otherwise upper)))) + +(defun org-element--cache-put (element &optional data) + "Store ELEMENT in current buffer's cache, if allowed. +When optional argument DATA is non-nil, assume is it object data +relative to ELEMENT and store it in the objects cache." + (cond ((not (org-element--cache-active-p)) nil) + ((not data) + (when org-element--cache-sync-requests + ;; During synchronization, first build an appropriate key + ;; for the new element so `avl-tree-enter' can insert it at + ;; the right spot in the cache. + (let ((keys (org-element--cache-find + (org-element-property :begin element) 'both))) + (puthash element + (org-element--cache-generate-key + (and (car keys) (org-element--cache-key (car keys))) + (cond ((cdr keys) (org-element--cache-key (cdr keys))) + (org-element--cache-sync-requests + (aref (car org-element--cache-sync-requests) 0)))) + org-element--cache-sync-keys))) + (avl-tree-enter org-element--cache element)) + ;; Headlines are not stored in cache, so objects in titles are + ;; not stored either. + ((eq (org-element-type element) 'headline) nil) + (t (puthash element data org-element--cache-objects)))) + +(defsubst org-element--cache-remove (element) + "Remove ELEMENT from cache. +Assume ELEMENT belongs to cache and that a cache is active." + (avl-tree-delete org-element--cache element) + (remhash element org-element--cache-objects)) + + +;;;; Synchronization + +(defsubst org-element--cache-set-timer (buffer) + "Set idle timer for cache synchronization in BUFFER." + (when org-element--cache-sync-timer + (cancel-timer org-element--cache-sync-timer)) + (setq org-element--cache-sync-timer + (run-with-idle-timer + (let ((idle (current-idle-time))) + (if idle (time-add idle org-element-cache-sync-break) + org-element-cache-sync-idle-time)) + nil + #'org-element--cache-sync + buffer))) + +(defsubst org-element--cache-interrupt-p (time-limit) + "Non-nil when synchronization process should be interrupted. +TIME-LIMIT is a time value or nil." + (and time-limit + (or (input-pending-p) + (time-less-p time-limit (current-time))))) + +(defsubst org-element--cache-shift-positions (element offset &optional props) + "Shift ELEMENT properties relative to buffer positions by OFFSET. + +Properties containing buffer positions are `:begin', `:end', +`:contents-begin', `:contents-end' and `:structure'. When +optional argument PROPS is a list of keywords, only shift +properties provided in that list. + +Properties are modified by side-effect." + (let ((properties (nth 1 element))) + ;; Shift `:structure' property for the first plain list only: it + ;; is the only one that really matters and it prevents from + ;; shifting it more than once. + (when (and (or (not props) (memq :structure props)) + (eq (org-element-type element) 'plain-list) + (not (eq (org-element-type (plist-get properties :parent)) + 'item))) + (dolist (item (plist-get properties :structure)) + (incf (car item) offset) + (incf (nth 6 item) offset))) + (dolist (key '(:begin :contents-begin :contents-end :end :post-affiliated)) + (let ((value (and (or (not props) (memq key props)) + (plist-get properties key)))) + (and value (plist-put properties key (+ offset value))))))) + +(defun org-element--cache-sync (buffer &optional threshold future-change) + "Synchronize cache with recent modification in BUFFER. + +When optional argument THRESHOLD is non-nil, do the +synchronization for all elements starting before or at threshold, +then exit. Otherwise, synchronize cache for as long as +`org-element-cache-sync-duration' or until Emacs leaves idle +state. + +FUTURE-CHANGE, when non-nil, is a buffer position where changes +not registered yet in the cache are going to happen. It is used +in `org-element--cache-submit-request', where cache is partially +updated before current modification are actually submitted." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (let ((inhibit-quit t) request next) + (when org-element--cache-sync-timer + (cancel-timer org-element--cache-sync-timer)) + (catch 'interrupt + (while org-element--cache-sync-requests + (setq request (car org-element--cache-sync-requests) + next (nth 1 org-element--cache-sync-requests)) + (org-element--cache-process-request + request + (and next (aref next 0)) + threshold + (and (not threshold) + (time-add (current-time) + org-element-cache-sync-duration)) + future-change) + ;; Request processed. Merge current and next offsets and + ;; transfer ending position. + (when next + (incf (aref next 3) (aref request 3)) + (aset next 2 (aref request 2))) + (setq org-element--cache-sync-requests + (cdr org-element--cache-sync-requests)))) + ;; If more requests are awaiting, set idle timer accordingly. + ;; Otherwise, reset keys. + (if org-element--cache-sync-requests + (org-element--cache-set-timer buffer) + (clrhash org-element--cache-sync-keys)))))) + +(defun org-element--cache-process-request + (request next threshold time-limit future-change) + "Process synchronization REQUEST for all entries before NEXT. + +REQUEST is a vector, built by `org-element--cache-submit-request'. + +NEXT is a cache key, as returned by `org-element--cache-key'. + +When non-nil, THRESHOLD is a buffer position. Synchronization +stops as soon as a shifted element begins after it. + +When non-nil, TIME-LIMIT is a time value. Synchronization stops +after this time or when Emacs exits idle state. + +When non-nil, FUTURE-CHANGE is a buffer position where changes +not registered yet in the cache are going to happen. See +`org-element--cache-submit-request' for more information. + +Throw `interrupt' if the process stops before completing the +request." + (catch 'quit + (when (= (aref request 5) 0) + ;; Phase 0. + ;; + ;; Delete all elements starting after BEG, but not after buffer + ;; position END or past element with key NEXT. Also delete + ;; elements contained within a previously removed element + ;; (stored in `last-container'). + ;; + ;; At each iteration, we start again at tree root since + ;; a deletion modifies structure of the balanced tree. + (catch 'end-phase + (while t + (when (org-element--cache-interrupt-p time-limit) + (throw 'interrupt nil)) + ;; Find first element in cache with key BEG or after it. + (let ((beg (aref request 0)) + (end (aref request 2)) + (node (org-element--cache-root)) + data data-key last-container) + (while node + (let* ((element (avl-tree--node-data node)) + (key (org-element--cache-key element))) + (cond + ((org-element--cache-key-less-p key beg) + (setq node (avl-tree--node-right node))) + ((org-element--cache-key-less-p beg key) + (setq data element + data-key key + node (avl-tree--node-left node))) + (t (setq data element + data-key key + node nil))))) + (if data + (let ((pos (org-element-property :begin data))) + (if (if (or (not next) + (org-element--cache-key-less-p data-key next)) + (<= pos end) + (and last-container + (let ((up data)) + (while (and up (not (eq up last-container))) + (setq up (org-element-property :parent up))) + up))) + (progn (when (and (not last-container) + (> (org-element-property :end data) + end)) + (setq last-container data)) + (org-element--cache-remove data)) + (aset request 0 data-key) + (aset request 1 pos) + (aset request 5 1) + (throw 'end-phase nil))) + ;; No element starting after modifications left in + ;; cache: further processing is futile. + (throw 'quit t)))))) + (when (= (aref request 5) 1) + ;; Phase 1. + ;; + ;; Phase 0 left a hole in the cache. Some elements after it + ;; could have parents within. For example, in the following + ;; buffer: + ;; + ;; - item + ;; + ;; + ;; Paragraph1 + ;; + ;; Paragraph2 + ;; + ;; if we remove a blank line between "item" and "Paragraph1", + ;; everything down to "Paragraph2" is removed from cache. But + ;; the paragraph now belongs to the list, and its `:parent' + ;; property no longer is accurate. + ;; + ;; Therefore we need to parse again elements in the hole, or at + ;; least in its last section, so that we can re-parent + ;; subsequent elements, during phase 2. + ;; + ;; Note that we only need to get the parent from the first + ;; element in cache after the hole. + ;; + ;; When next key is lesser or equal to the current one, delegate + ;; phase 1 processing to next request in order to preserve key + ;; order among requests. + (let ((key (aref request 0))) + (when (and next (not (org-element--cache-key-less-p key next))) + (let ((next-request (nth 1 org-element--cache-sync-requests))) + (aset next-request 0 key) + (aset next-request 1 (aref request 1)) + (aset next-request 5 1)) + (throw 'quit t))) + ;; Next element will start at its beginning position plus + ;; offset, since it hasn't been shifted yet. Therefore, LIMIT + ;; contains the real beginning position of the first element to + ;; shift and re-parent. + (let ((limit (+ (aref request 1) (aref request 3)))) + (cond ((and threshold (> limit threshold)) (throw 'interrupt nil)) + ((and future-change (>= limit future-change)) + ;; Changes are going to happen around this element and + ;; they will trigger another phase 1 request. Skip the + ;; current one. + (aset request 5 2)) + (t + (let ((parent (org-element--parse-to limit t time-limit))) + (aset request 4 parent) + (aset request 5 2)))))) + ;; Phase 2. + ;; + ;; Shift all elements starting from key START, but before NEXT, by + ;; OFFSET, and re-parent them when appropriate. + ;; + ;; Elements are modified by side-effect so the tree structure + ;; remains intact. + ;; + ;; Once THRESHOLD, if any, is reached, or once there is an input + ;; pending, exit. Before leaving, the current synchronization + ;; request is updated. + (let ((start (aref request 0)) + (offset (aref request 3)) + (parent (aref request 4)) + (node (org-element--cache-root)) + (stack (list nil)) + (leftp t) + exit-flag) + ;; No re-parenting nor shifting planned: request is over. + (when (and (not parent) (zerop offset)) (throw 'quit t)) + (while node + (let* ((data (avl-tree--node-data node)) + (key (org-element--cache-key data))) + (if (and leftp (avl-tree--node-left node) + (not (org-element--cache-key-less-p key start))) + (progn (push node stack) + (setq node (avl-tree--node-left node))) + (unless (org-element--cache-key-less-p key start) + ;; We reached NEXT. Request is complete. + (when (equal key next) (throw 'quit t)) + ;; Handle interruption request. Update current request. + (when (or exit-flag (org-element--cache-interrupt-p time-limit)) + (aset request 0 key) + (aset request 4 parent) + (throw 'interrupt nil)) + ;; Shift element. + (unless (zerop offset) + (org-element--cache-shift-positions data offset) + ;; Shift associated objects data, if any. + (dolist (object-data (gethash data org-element--cache-objects)) + (dolist (object (cddr object-data)) + (org-element--cache-shift-positions object offset)))) + (let ((begin (org-element-property :begin data))) + ;; Update PARENT and re-parent DATA, only when + ;; necessary. Propagate new structures for lists. + (while (and parent + (<= (org-element-property :end parent) begin)) + (setq parent (org-element-property :parent parent))) + (cond ((and (not parent) (zerop offset)) (throw 'quit nil)) + ((and parent + (let ((p (org-element-property :parent data))) + (or (not p) + (< (org-element-property :begin p) + (org-element-property :begin parent))))) + (org-element-put-property data :parent parent) + (let ((s (org-element-property :structure parent))) + (when (and s (org-element-property :structure data)) + (org-element-put-property data :structure s))))) + ;; Cache is up-to-date past THRESHOLD. Request + ;; interruption. + (when (and threshold (> begin threshold)) (setq exit-flag t)))) + (setq node (if (setq leftp (avl-tree--node-right node)) + (avl-tree--node-right node) + (pop stack)))))) + ;; We reached end of tree: synchronization complete. + t))) + +(defun org-element--parse-to (pos &optional syncp time-limit) + "Parse elements in current section, down to POS. + +Start parsing from the closest between the last known element in +cache or headline above. Return the smallest element containing +POS. + +When optional argument SYNCP is non-nil, return the parent of the +element containing POS instead. In that case, it is also +possible to provide TIME-LIMIT, which is a time value specifying +when the parsing should stop. The function throws `interrupt' if +the process stopped before finding the expected result." + (catch 'exit + (org-with-wide-buffer + (goto-char pos) + (let* ((cached (and (org-element--cache-active-p) + (org-element--cache-find pos nil))) + (begin (org-element-property :begin cached)) + element next mode) + (cond + ;; Nothing in cache before point: start parsing from first + ;; element following headline above, or first element in + ;; buffer. + ((not cached) + (when (org-with-limited-levels (outline-previous-heading)) + (setq mode 'planning) + (forward-line)) + (skip-chars-forward " \r\t\n") + (beginning-of-line)) + ;; Cache returned exact match: return it. + ((= pos begin) + (throw 'exit (if syncp (org-element-property :parent cached) cached))) + ;; There's a headline between cached value and POS: cached + ;; value is invalid. Start parsing from first element + ;; following the headline. + ((re-search-backward + (org-with-limited-levels org-outline-regexp-bol) begin t) + (forward-line) + (skip-chars-forward " \r\t\n") + (beginning-of-line) + (setq mode 'planning)) + ;; Check if CACHED or any of its ancestors contain point. + ;; + ;; If there is such an element, we inspect it in order to know + ;; if we return it or if we need to parse its contents. + ;; Otherwise, we just start parsing from current location, + ;; which is right after the top-most element containing + ;; CACHED. + ;; + ;; As a special case, if POS is at the end of the buffer, we + ;; want to return the innermost element ending there. + ;; + ;; Also, if we find an ancestor and discover that we need to + ;; parse its contents, make sure we don't start from + ;; `:contents-begin', as we would otherwise go past CACHED + ;; again. Instead, in that situation, we will resume parsing + ;; from NEXT, which is located after CACHED or its higher + ;; ancestor not containing point. + (t + (let ((up cached) + (pos (if (= (point-max) pos) (1- pos) pos))) + (goto-char (or (org-element-property :contents-begin cached) begin)) + (while (let ((end (org-element-property :end up))) + (and (<= end pos) + (goto-char end) + (setq up (org-element-property :parent up))))) + (cond ((not up)) + ((eobp) (setq element up)) + (t (setq element up next (point))))))) + ;; Parse successively each element until we reach POS. + (let ((end (or (org-element-property :end element) + (save-excursion + (org-with-limited-levels (outline-next-heading)) + (point)))) + (parent element)) + (while t + (when syncp + (cond ((= (point) pos) (throw 'exit parent)) + ((org-element--cache-interrupt-p time-limit) + (throw 'interrupt nil)))) + (unless element + (setq element (org-element--current-element + end 'element mode + (org-element-property :structure parent))) + (org-element-put-property element :parent parent) + (org-element--cache-put element)) + (let ((elem-end (org-element-property :end element)) + (type (org-element-type element))) + (cond + ;; Skip any element ending before point. Also skip + ;; element ending at point (unless it is also the end of + ;; buffer) since we're sure that another element begins + ;; after it. + ((and (<= elem-end pos) (/= (point-max) elem-end)) + (goto-char elem-end) + (setq mode (org-element--next-mode type nil))) + ;; A non-greater element contains point: return it. + ((not (memq type org-element-greater-elements)) + (throw 'exit element)) + ;; Otherwise, we have to decide if ELEMENT really + ;; contains POS. In that case we start parsing from + ;; contents' beginning. + ;; + ;; If POS is at contents' beginning but it is also at + ;; the beginning of the first item in a list or a table. + ;; In that case, we need to create an anchor for that + ;; list or table, so return it. + ;; + ;; Also, if POS is at the end of the buffer, no element + ;; can start after it, but more than one may end there. + ;; Arbitrarily, we choose to return the innermost of + ;; such elements. + ((let ((cbeg (org-element-property :contents-begin element)) + (cend (org-element-property :contents-end element))) + (when (or syncp + (and cbeg cend + (or (< cbeg pos) + (and (= cbeg pos) + (not (memq type '(plain-list table))))) + (or (> cend pos) + (and (= cend pos) (= (point-max) pos))))) + (goto-char (or next cbeg)) + (setq next nil + mode (org-element--next-mode type t) + parent element + end cend)))) + ;; Otherwise, return ELEMENT as it is the smallest + ;; element containing POS. + (t (throw 'exit element)))) + (setq element nil))))))) + + +;;;; Staging Buffer Changes + +(defconst org-element--cache-sensitive-re + (concat + org-outline-regexp-bol "\\|" + "\\\\end{[A-Za-z0-9*]+}[ \t]*$" "\\|" + "^[ \t]*\\(?:" + "#\\+\\(?:BEGIN[:_]\\|END\\(?:_\\|:?[ \t]*$\\)\\)" "\\|" + "\\\\begin{[A-Za-z0-9*]+}" "\\|" + ":\\(?:\\w\\|[-_]\\)+:[ \t]*$" + "\\)") + "Regexp matching a sensitive line, structure wise. +A sensitive line is a headline, inlinetask, block, drawer, or +latex-environment boundary. When such a line is modified, +structure changes in the document may propagate in the whole +section, possibly making cache invalid.") + +(defvar org-element--cache-change-warning nil + "Non-nil when a sensitive line is about to be changed. +It is a symbol among nil, t and `headline'.") + +(defun org-element--cache-before-change (beg end) + "Request extension of area going to be modified if needed. +BEG and END are the beginning and end of the range of changed +text. See `before-change-functions' for more information." + (when (org-element--cache-active-p) + (org-with-wide-buffer + (goto-char beg) + (beginning-of-line) + (let ((bottom (save-excursion (goto-char end) (line-end-position)))) + (setq org-element--cache-change-warning + (save-match-data + (if (and (org-with-limited-levels (org-at-heading-p)) + (= (line-end-position) bottom)) + 'headline + (let ((case-fold-search t)) + (re-search-forward + org-element--cache-sensitive-re bottom t))))))))) + +(defun org-element--cache-after-change (beg end pre) + "Update buffer modifications for current buffer. +BEG and END are the beginning and end of the range of changed +text, and the length in bytes of the pre-change text replaced by +that range. See `after-change-functions' for more information." + (when (org-element--cache-active-p) + (org-with-wide-buffer + (goto-char beg) + (beginning-of-line) + (save-match-data + (let ((top (point)) + (bottom (save-excursion (goto-char end) (line-end-position)))) + ;; Determine if modified area needs to be extended, according + ;; to both previous and current state. We make a special + ;; case for headline editing: if a headline is modified but + ;; not removed, do not extend. + (when (case org-element--cache-change-warning + ((t) t) + (headline + (not (and (org-with-limited-levels (org-at-heading-p)) + (= (line-end-position) bottom)))) + (otherwise + (let ((case-fold-search t)) + (re-search-forward + org-element--cache-sensitive-re bottom t)))) + ;; Effectively extend modified area. + (org-with-limited-levels + (setq top (progn (goto-char top) + (when (outline-previous-heading) (forward-line)) + (point))) + (setq bottom (progn (goto-char bottom) + (if (outline-next-heading) (1- (point)) + (point)))))) + ;; Store synchronization request. + (let ((offset (- end beg pre))) + (org-element--cache-submit-request top (- bottom offset) offset))))) + ;; Activate a timer to process the request during idle time. + (org-element--cache-set-timer (current-buffer)))) + +(defun org-element--cache-for-removal (beg end offset) + "Return first element to remove from cache. + +BEG and END are buffer positions delimiting buffer modifications. +OFFSET is the size of the changes. + +Returned element is usually the first element in cache containing +any position between BEG and END. As an exception, greater +elements around the changes that are robust to contents +modifications are preserved and updated according to the +changes." + (let* ((elements (org-element--cache-find (1- beg) 'both)) + (before (car elements)) + (after (cdr elements))) + (if (not before) after + (let ((up before) + (robust-flag t)) + (while up + (if (let ((type (org-element-type up))) + (and (or (memq type '(center-block dynamic-block quote-block + special-block)) + ;; Drawers named "PROPERTIES" are probably + ;; a properties drawer being edited. Force + ;; parsing to check if editing is over. + (and (eq type 'drawer) + (not (string= + (org-element-property :drawer-name up) + "PROPERTIES")))) + (let ((cbeg (org-element-property :contents-begin up))) + (and cbeg + (<= cbeg beg) + (> (org-element-property :contents-end up) end))))) + ;; UP is a robust greater element containing changes. + ;; We only need to extend its ending boundaries. + (org-element--cache-shift-positions + up offset '(:contents-end :end)) + (setq before up) + (when robust-flag (setq robust-flag nil))) + (setq up (org-element-property :parent up))) + ;; We're at top level element containing ELEMENT: if it's + ;; altered by buffer modifications, it is first element in + ;; cache to be removed. Otherwise, that first element is the + ;; following one. + ;; + ;; As a special case, do not remove BEFORE if it is a robust + ;; container for current changes. + (if (or (< (org-element-property :end before) beg) robust-flag) after + before))))) + +(defun org-element--cache-submit-request (beg end offset) + "Submit a new cache synchronization request for current buffer. +BEG and END are buffer positions delimiting the minimal area +where cache data should be removed. OFFSET is the size of the +change, as an integer." + (let ((next (car org-element--cache-sync-requests)) + delete-to delete-from) + (if (and next + (zerop (aref next 5)) + (> (setq delete- |