summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
authorSébastien Delafond <sdelafond@gmail.com>2015-08-25 12:27:35 +0200
committerSébastien Delafond <sdelafond@gmail.com>2015-08-25 12:27:35 +0200
commit1be13d57dc8357576a8285c6dadc03db9e3ed7b0 (patch)
treee35b32d4dbd60cb6cea09f3c0797cc8877352def /lisp
parent4dc4918d0d667f18f3d5e3dd71e6f117ddb8af8a (diff)
Imported Upstream version 8.3.1
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ob-C.el396
-rw-r--r--lisp/ob-J.el179
-rw-r--r--lisp/ob-R.el200
-rw-r--r--lisp/ob-abc.el94
-rw-r--r--lisp/ob-asymptote.el5
-rw-r--r--lisp/ob-awk.el23
-rw-r--r--lisp/ob-clojure.el82
-rw-r--r--lisp/ob-comint.el83
-rw-r--r--lisp/ob-coq.el77
-rw-r--r--lisp/ob-core.el972
-rw-r--r--lisp/ob-ditaa.el18
-rw-r--r--lisp/ob-dot.el4
-rw-r--r--lisp/ob-ebnf.el85
-rw-r--r--lisp/ob-emacs-lisp.el5
-rw-r--r--lisp/ob-eval.el7
-rw-r--r--lisp/ob-exp.el349
-rw-r--r--lisp/ob-forth.el86
-rw-r--r--lisp/ob-fortran.el6
-rw-r--r--lisp/ob-gnuplot.el21
-rw-r--r--lisp/ob-groovy.el118
-rw-r--r--lisp/ob-haskell.el8
-rw-r--r--lisp/ob-io.el10
-rw-r--r--lisp/ob-java.el22
-rw-r--r--lisp/ob-js.el9
-rw-r--r--lisp/ob-keys.el1
-rw-r--r--lisp/ob-latex.el96
-rw-r--r--lisp/ob-lilypond.el149
-rw-r--r--lisp/ob-lisp.el34
-rw-r--r--lisp/ob-lob.el35
-rw-r--r--lisp/ob-maxima.el9
-rw-r--r--lisp/ob-ocaml.el65
-rw-r--r--lisp/ob-octave.el12
-rw-r--r--lisp/ob-processing.el197
-rw-r--r--lisp/ob-python.el8
-rw-r--r--lisp/ob-ref.el212
-rw-r--r--lisp/ob-ruby.el43
-rw-r--r--lisp/ob-scala.el10
-rw-r--r--lisp/ob-scheme.el23
-rw-r--r--lisp/ob-sed.el107
-rw-r--r--lisp/ob-shell.el (renamed from lisp/ob-sh.el)130
-rw-r--r--lisp/ob-sql.el24
-rw-r--r--lisp/ob-table.el32
-rw-r--r--lisp/ob-tangle.el146
-rw-r--r--lisp/org-agenda.el936
-rw-r--r--lisp/org-archive.el90
-rw-r--r--lisp/org-attach.el31
-rw-r--r--lisp/org-bbdb.el2
-rw-r--r--lisp/org-bibtex.el41
-rw-r--r--lisp/org-capture.el88
-rw-r--r--lisp/org-clock.el740
-rw-r--r--lisp/org-colview.el531
-rw-r--r--lisp/org-compat.el34
-rw-r--r--lisp/org-ctags.el8
-rw-r--r--lisp/org-docview.el21
-rw-r--r--lisp/org-element.el4857
-rw-r--r--lisp/org-entities.el932
-rw-r--r--lisp/org-faces.el109
-rw-r--r--lisp/org-feed.el12
-rw-r--r--lisp/org-footnote.el675
-rw-r--r--lisp/org-gnus.el16
-rw-r--r--lisp/org-habit.el66
-rw-r--r--lisp/org-info.el32
-rw-r--r--lisp/org-inlinetask.el24
-rw-r--r--lisp/org-list.el573
-rw-r--r--lisp/org-loaddefs.el546
-rw-r--r--lisp/org-macro.el149
-rw-r--r--lisp/org-macs.el75
-rw-r--r--lisp/org-mobile.el11
-rw-r--r--lisp/org-mouse.el13
-rw-r--r--lisp/org-pcomplete.el23
-rw-r--r--lisp/org-plot.el148
-rw-r--r--lisp/org-protocol.el2
-rw-r--r--lisp/org-rmail.el2
-rw-r--r--lisp/org-src.el1407
-rw-r--r--lisp/org-table.el3804
-rw-r--r--lisp/org-timer.el266
-rw-r--r--lisp/org-version.el4
-rwxr-xr-x[-rw-r--r--]lisp/org.el9823
-rw-r--r--lisp/ox-ascii.el754
-rw-r--r--lisp/ox-beamer.el207
-rw-r--r--lisp/ox-html.el1380
-rw-r--r--lisp/ox-icalendar.el349
-rw-r--r--lisp/ox-latex.el1924
-rw-r--r--lisp/ox-man.el120
-rw-r--r--lisp/ox-md.el155
-rw-r--r--lisp/ox-odt.el682
-rw-r--r--lisp/ox-org.el94
-rw-r--r--lisp/ox-publish.el243
-rw-r--r--lisp/ox-texinfo.el463
-rw-r--r--lisp/ox.el2756
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-