summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ob-C.el150
-rw-r--r--lisp/ob-J.el25
-rw-r--r--lisp/ob-R.el76
-rw-r--r--lisp/ob-abc.el20
-rw-r--r--lisp/ob-asymptote.el42
-rw-r--r--lisp/ob-awk.el27
-rw-r--r--lisp/ob-calc.el20
-rw-r--r--lisp/ob-clojure.el35
-rw-r--r--lisp/ob-comint.el34
-rw-r--r--lisp/ob-coq.el9
-rw-r--r--lisp/ob-core.el2150
-rw-r--r--lisp/ob-css.el8
-rw-r--r--lisp/ob-ditaa.el20
-rw-r--r--lisp/ob-dot.el13
-rw-r--r--lisp/ob-ebnf.el8
-rw-r--r--lisp/ob-emacs-lisp.el53
-rw-r--r--lisp/ob-eval.el27
-rw-r--r--lisp/ob-exp.el501
-rw-r--r--lisp/ob-forth.el15
-rw-r--r--lisp/ob-fortran.el53
-rw-r--r--lisp/ob-gnuplot.el52
-rw-r--r--lisp/ob-groovy.el22
-rw-r--r--lisp/ob-haskell.el52
-rw-r--r--lisp/ob-io.el34
-rw-r--r--lisp/ob-java.el24
-rw-r--r--lisp/ob-js.el19
-rw-r--r--lisp/ob-keys.el6
-rw-r--r--lisp/ob-latex.el72
-rw-r--r--lisp/ob-ledger.el7
-rw-r--r--lisp/ob-lilypond.el37
-rw-r--r--lisp/ob-lisp.el88
-rw-r--r--lisp/ob-lob.el194
-rw-r--r--lisp/ob-lua.el403
-rw-r--r--lisp/ob-makefile.el8
-rw-r--r--lisp/ob-matlab.el2
-rw-r--r--lisp/ob-maxima.el10
-rw-r--r--lisp/ob-mscgen.el10
-rw-r--r--lisp/ob-ocaml.el58
-rw-r--r--lisp/ob-octave.el66
-rw-r--r--lisp/ob-org.el8
-rw-r--r--lisp/ob-perl.el27
-rw-r--r--lisp/ob-picolisp.el14
-rw-r--r--lisp/ob-plantuml.el27
-rw-r--r--lisp/ob-processing.el30
-rw-r--r--lisp/ob-python.el94
-rw-r--r--lisp/ob-ref.el162
-rw-r--r--lisp/ob-ruby.el66
-rw-r--r--lisp/ob-sass.el9
-rw-r--r--lisp/ob-scala.el28
-rw-r--r--lisp/ob-scheme.el31
-rw-r--r--lisp/ob-screen.el20
-rw-r--r--lisp/ob-sed.el2
-rw-r--r--lisp/ob-shell.el87
-rw-r--r--lisp/ob-shen.el9
-rw-r--r--lisp/ob-sql.el187
-rw-r--r--lisp/ob-sqlite.el23
-rw-r--r--lisp/ob-stan.el84
-rw-r--r--lisp/ob-table.el12
-rw-r--r--lisp/ob-tangle.el108
-rw-r--r--lisp/ob.el2
-rw-r--r--lisp/org-agenda.el1770
-rw-r--r--lisp/org-archive.el311
-rw-r--r--lisp/org-attach.el120
-rw-r--r--lisp/org-bbdb.el110
-rw-r--r--lisp/org-bibtex.el120
-rw-r--r--lisp/org-capture.el733
-rw-r--r--lisp/org-clock.el835
-rw-r--r--lisp/org-colview.el2162
-rw-r--r--lisp/org-compat.el684
-rw-r--r--lisp/org-crypt.el133
-rw-r--r--lisp/org-ctags.el101
-rw-r--r--lisp/org-datetree.el238
-rw-r--r--lisp/org-docview.el13
-rw-r--r--lisp/org-element.el1669
-rw-r--r--lisp/org-entities.el112
-rw-r--r--lisp/org-eshell.el9
-rw-r--r--lisp/org-eww.el172
-rw-r--r--lisp/org-faces.el484
-rw-r--r--lisp/org-feed.el149
-rw-r--r--lisp/org-footnote.el1141
-rw-r--r--lisp/org-gnus.el55
-rw-r--r--lisp/org-habit.el104
-rw-r--r--lisp/org-id.el27
-rw-r--r--lisp/org-indent.el61
-rw-r--r--lisp/org-info.el64
-rw-r--r--lisp/org-inlinetask.el32
-rw-r--r--lisp/org-irc.el26
-rw-r--r--lisp/org-lint.el159
-rw-r--r--lisp/org-list.el987
-rw-r--r--lisp/org-loaddefs.el1204
-rw-r--r--lisp/org-macro.el207
-rw-r--r--lisp/org-macs.el146
-rw-r--r--lisp/org-mhe.el39
-rw-r--r--lisp/org-mobile.el233
-rw-r--r--lisp/org-mouse.el139
-rw-r--r--lisp/org-pcomplete.el82
-rw-r--r--lisp/org-plot.el163
-rw-r--r--lisp/org-protocol.el345
-rw-r--r--lisp/org-rmail.el24
-rw-r--r--lisp/org-src.el291
-rw-r--r--lisp/org-table.el708
-rw-r--r--lisp/org-timer.el140
-rw-r--r--lisp/org-version.el10
-rw-r--r--lisp/org-w3m.el16
-rw-r--r--lisp/org.el9957
-rw-r--r--lisp/ox-ascii.el348
-rw-r--r--lisp/ox-beamer.el135
-rw-r--r--lisp/ox-html.el949
-rw-r--r--lisp/ox-icalendar.el93
-rw-r--r--lisp/ox-latex.el800
-rw-r--r--lisp/ox-man.el381
-rw-r--r--lisp/ox-md.el161
-rw-r--r--lisp/ox-odt.el1078
-rw-r--r--lisp/ox-org.el22
-rw-r--r--lisp/ox-publish.el480
-rw-r--r--lisp/ox-texinfo.el314
-rw-r--r--lisp/ox.el2135
117 files changed, 20109 insertions, 18552 deletions
diff --git a/lisp/ob-C.el b/lisp/ob-C.el
index a6d4d5e..0bd911e 100644
--- a/lisp/ob-C.el
+++ b/lisp/ob-C.el
@@ -1,4 +1,4 @@
-;;; ob-C.el --- org-babel functions for C and similar languages
+;;; ob-C.el --- Babel Functions for C and Similar Languages -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -31,12 +31,14 @@
;; - not much in the way of error feedback
;;; Code:
-(require 'ob)
+
(require 'cc-mode)
+(require 'ob)
+
-(declare-function org-entry-get "org"
- (pom property &optional inherit literal-nil))
+(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
(declare-function org-remove-indentation "org" (code &optional n))
+(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("C++" . "cpp"))
@@ -120,39 +122,47 @@ header arguments."
or `org-babel-execute:C++' or `org-babel-execute:D'."
(let* ((tmp-src-file (org-babel-temp-file
"C-src-"
- (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)))
+ (pcase org-babel-c-variant
+ (`c ".c") (`cpp ".cpp") (`d ".d"))))
+ (tmp-bin-file ;not used for D
+ (org-babel-temp-file "C-bin-" org-babel-exeext))
+ (cmdline (cdr (assq :cmdline params)))
(cmdline (if cmdline (concat " " cmdline) ""))
- (flags (cdr (assoc :flags params)))
+ (flags (cdr (assq :flags params)))
(flags (mapconcat 'identity
(if (listp flags) flags (list flags)) " "))
+ (libs (org-babel-read
+ (or (cdr (assq :libs params))
+ (org-entry-get nil "libs" t))
+ nil))
+ (libs (mapconcat #'identity
+ (if (listp libs) libs (list libs))
+ " "))
(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)))))
+ (pcase 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)
+ (pcase org-babel-c-variant
+ ((or `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))
+ (format "%s -o %s %s %s %s"
+ (pcase 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
+ (org-babel-process-file-name tmp-src-file)
+ libs)
+ ""))
+ (`d nil)) ;; no separate compilation for D
(let ((results
(org-babel-eval
- (case org-babel-c-variant
- ((c cpp)
+ (pcase org-babel-c-variant
+ ((or `c `cpp)
(concat tmp-bin-file cmdline))
- (d
+ (`d
(format "%s %s %s %s"
org-babel-D-compiler
flags
@@ -160,17 +170,17 @@ or `org-babel-execute:C++' or `org-babel-execute:D'."
cmdline)))
"")))
(when results
- (setq results (org-babel-trim (org-remove-indentation results)))
+ (setq results (org-trim (org-remove-indentation results)))
(org-babel-reassemble-table
- (org-babel-result-cond (cdr (assoc :result-params params))
+ (org-babel-result-cond (cdr (assq :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)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))
)))
(defun org-babel-C-expand-C++ (body params)
@@ -181,15 +191,15 @@ its header arguments."
(defun org-babel-C-expand-C (body params)
"Expand a block of C or C++ code with org-babel according to
its 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")))
+ (let ((vars (org-babel--get-vars params))
+ (colnames (cdr (assq :colname-names params)))
+ (main-p (not (string= (cdr (assq :main params)) "no")))
(includes (org-babel-read
- (or (cdr (assoc :includes params))
+ (or (cdr (assq :includes params))
(org-entry-get nil "includes" t))
nil))
(defines (org-babel-read
- (or (cdr (assoc :defines params))
+ (or (cdr (assq :defines params))
(org-entry-get nil "defines" t))
nil)))
(when (stringp includes)
@@ -230,10 +240,10 @@ its header arguments."
(defun org-babel-C-expand-D (body params)
"Expand a block of D code with org-babel according to
its 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))
+ (let ((vars (org-babel--get-vars params))
+ (colnames (cdr (assq :colname-names params)))
+ (main-p (not (string= (cdr (assq :main params)) "no")))
+ (imports (or (cdr (assq :imports params))
(org-babel-read (org-entry-get nil "imports" t)))))
(when (stringp imports)
(setq imports (split-string imports)))
@@ -265,12 +275,12 @@ its header arguments."
body
(format "int main() {\n%s\nreturn 0;\n}\n" body)))
-(defun org-babel-prep-session:C (session params)
+(defun org-babel-prep-session:C (_session _params)
"This function does nothing as C is a compiled language with no
support for sessions"
(error "C is a compiled languages -- no support for sessions"))
-(defun org-babel-load-session:C (session body params)
+(defun org-babel-load-session:C (_session _body _params)
"This function does nothing as C is a compiled language with no
support for sessions"
(error "C is a compiled languages -- no support for sessions"))
@@ -290,14 +300,14 @@ 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
+ (pcase basetype
+ (`integerp '("int" "%d"))
+ (`floatp '("double" "%f"))
+ (`stringp
(list
- (if (equal org-babel-c-variant 'd) "string" "const char*")
+ (if (eq org-babel-c-variant 'd) "string" "const char*")
"\"%s\""))
- (t (error "unknown type %S" basetype)))))
+ (_ (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
@@ -307,25 +317,25 @@ FORMAT can be either a format string or a function which is called with VAL."
(cons
(format "[%d][%d]" (length val) (length (car val)))
(concat
- (if (equal org-babel-c-variant 'd) "[\n" "{\n")
+ (if (eq org-babel-c-variant 'd) "[\n" "{\n")
(mapconcat
(lambda (v)
(concat
- (if (equal org-babel-c-variant 'd) " [" " {")
+ (if (eq org-babel-c-variant 'd) " [" " {")
(mapconcat (lambda (w) (format ,(cadr type) w)) v ",")
- (if (equal org-babel-c-variant 'd) "]" "}")))
+ (if (eq org-babel-c-variant 'd) "]" "}")))
val
",\n")
- (if (equal org-babel-c-variant 'd) "\n]" "\n}"))))))
+ (if (eq 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) "[" "{")
+ (if (eq org-babel-c-variant 'd) "[" "{")
(mapconcat (lambda (v) (format ,(cadr type) v)) val ",")
- (if (equal org-babel-c-variant 'd) "]" "}"))))))
+ (if (eq org-babel-c-variant 'd) "]" "}"))))))
(t ;; treat unknown types as string
type))))
@@ -340,12 +350,12 @@ FORMAT can be either a format string or a function which is called with VAL."
((or (listp val) (vectorp val))
(let ((type nil))
(mapc (lambda (v)
- (case (org-babel-C-val-to-base-type v)
- (stringp (setq type 'stringp))
- (floatp
+ (pcase (org-babel-C-val-to-base-type v)
+ (`stringp (setq type 'stringp))
+ (`floatp
(if (or (not type) (eq type 'integerp))
(setq type 'floatp)))
- (integerp
+ (`integerp
(unless type (setq type 'integerp)))))
val)
type))
@@ -387,8 +397,8 @@ of the same value."
(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)
+ (pcase org-babel-c-variant
+ ((or `c `cpp)
"int get_column_num (int nbcols, const char** header, const char* column)
{
int c;
@@ -397,9 +407,8 @@ into a column number."
return c;
return -1;
}
-"
- )
- (d
+")
+ (`d
"int get_column_num (string[] header, string column)
{
foreach (c, h; header)
@@ -407,8 +416,7 @@ into a column number."
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
@@ -417,21 +425,21 @@ specifying a variable with the name of the table."
(headers (cdr head)))
(concat
(format
- (case org-babel-c-variant
- ((c cpp) "const char* %s_header[%d] = {%s};")
- (d "string %s_header[%d] = [%s];"))
+ (pcase org-babel-c-variant
+ ((or `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)
+ (pcase org-babel-c-variant
+ ((or `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
+ (`d
(format
- "string %s_h (ulong row, string col) { return %s[row][get_column_num(%s_header,col)]; }"
+ "string %s_h (size_t row, string col) { return %s[row][get_column_num(%s_header,col)]; }"
table table table))))))
(provide 'ob-C)
diff --git a/lisp/ob-J.el b/lisp/ob-J.el
index dcdad03..572149b 100644
--- a/lisp/ob-J.el
+++ b/lisp/ob-J.el
@@ -1,4 +1,4 @@
-;;; ob-J.el --- org-babel functions for J evaluation
+;;; ob-J.el --- Babel Functions for J -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
@@ -29,12 +29,20 @@
;; (available in MELPA).
;;; Code:
+
(require 'ob)
-(declare-function org-trim "org" (S))
+(declare-function org-trim "org" (s &optional keep-lead))
(declare-function j-console-ensure-session "ext:j-console" ())
-(defun org-babel-expand-body:J (body params &optional processed-params)
+(defcustom org-babel-J-command "jconsole"
+ "Command to call J."
+ :group 'org-babel
+ :version "25.2"
+ :package-version '(Org . "9.0")
+ :type 'string)
+
+(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))
@@ -59,26 +67,25 @@ PROCESSED-PARAMS isn't used yet."
(org-babel-J-interleave-echos-except-functions s3)))
(org-babel-J-interleave-echos body)))
+(defalias 'org-babel-execute:j 'org-babel-execute:J)
+
(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))
+ (sessionp (cdr (assq :session params)))
(full-body (org-babel-expand-body:J
body params processed-params))
(tmp-script-file (org-babel-temp-file "J-src")))
+ (org-babel-j-initiate-session sessionp)
(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-eval (format "%s < %s" org-babel-J-command tmp-script-file) ""))
(org-babel-J-eval-string full-body)))))
(defun org-babel-J-eval-string (str)
diff --git a/lisp/ob-R.el b/lisp/ob-R.el
index 4b37c18..2993b09 100644
--- a/lisp/ob-R.el
+++ b/lisp/ob-R.el
@@ -1,4 +1,4 @@
-;;; ob-R.el --- org-babel functions for R code evaluation
+;;; ob-R.el --- Babel Functions for R -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -27,8 +27,9 @@
;; Org-Babel support for evaluating R code
;;; Code:
+
+(require 'cl-lib)
(require 'ob)
-(eval-when-compile (require 'cl))
(declare-function orgtbl-to-tsv "org-table" (table params))
(declare-function R "ext:essd-r" (&optional start-args))
@@ -36,10 +37,7 @@
(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))
+ (&optional proc sec-prompt wait force-redisplay))
(defconst org-babel-header-args:R
'((width . :any)
@@ -92,9 +90,11 @@ this variable.")
(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)))))
+ (let ((session (cdr (assq :session (nth 2 info)))))
+ (when (and session
+ (string-prefix-p "*" session)
+ (string-suffix-p "*" session))
+ (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
@@ -139,28 +139,28 @@ This function is used when the table contains a header.")
This function is used when the table does not contain a header.")
-(defun org-babel-expand-body:R (body params &optional graphics-file)
+(defun org-babel-expand-body:R (body params &optional _graphics-file)
"Expand BODY according to PARAMS, return the expanded body."
(mapconcat 'identity
(append
- (when (cdr (assoc :prologue params))
- (list (cdr (assoc :prologue params))))
+ (when (cdr (assq :prologue params))
+ (list (cdr (assq :prologue params))))
(org-babel-variable-assignments:R params)
(list body)
- (when (cdr (assoc :epilogue params))
- (list (cdr (assoc :epilogue params)))))
+ (when (cdr (assq :epilogue params))
+ (list (cdr (assq :epilogue params)))))
"\n"))
(defun org-babel-execute:R (body params)
"Execute a block of R code.
This function is called by `org-babel-execute-src-block'."
(save-excursion
- (let* ((result-params (cdr (assoc :result-params params)))
- (result-type (cdr (assoc :result-type params)))
+ (let* ((result-params (cdr (assq :result-params params)))
+ (result-type (cdr (assq :result-type params)))
(session (org-babel-R-initiate-session
- (cdr (assoc :session params)) params))
- (colnames-p (cdr (assoc :colnames params)))
- (rownames-p (cdr (assoc :rownames params)))
+ (cdr (assq :session params)) params))
+ (colnames-p (cdr (assq :colnames params)))
+ (rownames-p (cdr (assq :rownames params)))
(graphics-file (and (member "graphics" (assq :result-params params))
(org-babel-graphical-output-file params)))
(full-body
@@ -180,10 +180,10 @@ This function is called by `org-babel-execute-src-block'."
session full-body result-type result-params
(or (equal "yes" colnames-p)
(org-babel-pick-name
- (cdr (assoc :colname-names params)) colnames-p))
+ (cdr (assq :colname-names params)) colnames-p))
(or (equal "yes" rownames-p)
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) rownames-p)))))
+ (cdr (assq :rowname-names params)) rownames-p)))))
(if graphics-file nil result))))
(defun org-babel-prep-session:R (session params)
@@ -209,21 +209,21 @@ 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 (org-babel--get-vars params)))
(mapcar
(lambda (pair)
(org-babel-R-assign-elisp
(car pair) (cdr pair)
- (equal "yes" (cdr (assoc :colnames params)))
- (equal "yes" (cdr (assoc :rownames params)))))
+ (equal "yes" (cdr (assq :colnames params)))
+ (equal "yes" (cdr (assq :rownames params)))))
(mapcar
(lambda (i)
(cons (car (nth i vars))
(org-babel-reassemble-table
(cdr (nth i vars))
- (cdr (nth i (cdr (assoc :colname-names params))))
- (cdr (nth i (cdr (assoc :rowname-names params)))))))
- (org-number-sequence 0 (1- (length vars)))))))
+ (cdr (nth i (cdr (assq :colname-names params))))
+ (cdr (nth i (cdr (assq :rowname-names params)))))))
+ (number-sequence 0 (1- (length vars)))))))
(defun org-babel-R-quote-tsv-field (s)
"Quote field S for export to R."
@@ -234,7 +234,7 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-R-assign-elisp (name value colnames-p rownames-p)
"Construct R code assigning the elisp VALUE to a variable named NAME."
(if (listp value)
- (let* ((lengths (mapcar 'length (org-remove-if-not 'sequencep value)))
+ (let* ((lengths (mapcar 'length (cl-remove-if-not 'sequencep value)))
(max (if lengths (apply 'max lengths) 0))
(min (if lengths (apply 'min lengths) 0)))
;; Ensure VALUE has an orgtbl structure (depth of at least 2).
@@ -262,7 +262,7 @@ This function is called by `org-babel-execute-src-block'."
(ess-ask-for-ess-directory
(and (boundp 'ess-ask-for-ess-directory)
ess-ask-for-ess-directory
- (not (cdr (assoc :dir params))))))
+ (not (cdr (assq :dir params))))))
(if (org-babel-comint-buffer-livep session)
session
(save-window-excursion
@@ -316,8 +316,7 @@ Each member of this list is a list with three members:
:type :family :title :fonts :version
:paper :encoding :pagecentre :colormodel
:useDingbats :horizontal))
- (device (and (string-match ".+\\.\\([^.]+\\)" out-file)
- (match-string 1 out-file)))
+ (device (file-name-extension out-file))
(device-info (or (assq (intern (concat ":" device))
org-babel-R-graphics-devices)
(assq :png org-babel-R-graphics-devices)))
@@ -379,12 +378,12 @@ Has four %s escapes to be filled in:
body result-type result-params column-names-p row-names-p)))
(defun org-babel-R-evaluate-external-process
- (body result-type result-params column-names-p row-names-p)
+ (body result-type result-params column-names-p row-names-p)
"Evaluate BODY in external R 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."
- (case result-type
+ (cl-case result-type
(value
(let ((tmp-file (org-babel-temp-file "R-")))
(org-babel-eval org-babel-R-command
@@ -399,7 +398,7 @@ last statement in BODY, as elisp."
(org-babel-result-cond result-params
(with-temp-buffer
(insert-file-contents tmp-file)
- (buffer-string))
+ (org-babel-chomp (buffer-string) "\n"))
(org-babel-import-elisp-from-file tmp-file '(16)))
column-names-p)))
(output (org-babel-eval org-babel-R-command body))))
@@ -407,12 +406,12 @@ last statement in BODY, as elisp."
(defvar ess-eval-visibly-p)
(defun org-babel-R-evaluate-session
- (session body result-type result-params column-names-p row-names-p)
+ (session body result-type result-params column-names-p row-names-p)
"Evaluate BODY in SESSION.
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."
- (case result-type
+ (cl-case result-type
(value
(with-temp-buffer
(insert (org-babel-chomp body))
@@ -433,7 +432,7 @@ last statement in BODY, as elisp."
(org-babel-result-cond result-params
(with-temp-buffer
(insert-file-contents tmp-file)
- (buffer-string))
+ (org-babel-chomp (buffer-string) "\n"))
(org-babel-import-elisp-from-file tmp-file '(16)))
column-names-p)))
(output
@@ -446,7 +445,8 @@ last statement in BODY, as elisp."
(mapcar
(lambda (line) ;; cleanup extra prompts left in output
(if (string-match
- "^\\([ ]*[>+\\.][ ]?\\)+\\([[0-9]+\\|[ ]\\)" line)
+ "^\\([>+.]\\([ ][>.+]\\)*[ ]\\)"
+ (car (split-string line "\n")))
(substring line (match-end 1))
line))
(org-babel-comint-with-output (session org-babel-R-eoe-output)
diff --git a/lisp/ob-abc.el b/lisp/ob-abc.el
index 36ad55d..6872b1c 100644
--- a/lisp/ob-abc.el
+++ b/lisp/ob-abc.el
@@ -1,4 +1,4 @@
-;;; ob-abc.el --- org-babel functions for template evaluation
+;;; ob-abc.el --- Org Babel Functions for ABC -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
@@ -42,7 +42,7 @@
(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))))
+ (let ((vars (org-babel--get-vars params)))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
@@ -59,12 +59,10 @@
"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)))))
+ (let* ((cmdline (cdr (assq :cmdline params)))
+ (out-file (let ((file (cdr (assq :file params))))
+ (if file (replace-regexp-in-string "\.pdf$" ".ps" file)
+ (error "abc code block requires :file header argument"))))
(in-file (org-babel-temp-file "abc-"))
(render (concat "abcm2ps" " " cmdline
" -O " (org-babel-process-file-name out-file)
@@ -79,14 +77,14 @@
(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))) ""))
+ (when (string= (file-name-extension (cdr (assq :file params))) "pdf")
+ (org-babel-eval (concat "ps2pdf" " " out-file " " (cdr (assq :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)
+(defun org-babel-prep-session:abc (_session _params)
"Return an error because abc does not support sessions."
(error "ABC does not support sessions"))
diff --git a/lisp/ob-asymptote.el b/lisp/ob-asymptote.el
index f6492ae..e69afc4 100644
--- a/lisp/ob-asymptote.el
+++ b/lisp/ob-asymptote.el
@@ -1,4 +1,4 @@
-;;; ob-asymptote.el --- org-babel functions for asymptote evaluation
+;;; ob-asymptote.el --- Babel Functions for Asymptote -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -43,7 +43,6 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("asymptote" . "asy"))
@@ -55,13 +54,10 @@
(defun org-babel-execute:asymptote (body params)
"Execute a block of Asymptote code.
This function is called by `org-babel-execute-src-block'."
- (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
- (out-file (cdr (assoc :file params)))
- (format (or (and out-file
- (string-match ".+\\.\\(.+\\)" out-file)
- (match-string 1 out-file))
+ (let* ((out-file (cdr (assq :file params)))
+ (format (or (file-name-extension out-file)
"pdf"))
- (cmdline (cdr (assoc :cmdline params)))
+ (cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "asymptote-"))
(cmd
(concat "asy "
@@ -79,7 +75,7 @@ This function is called by `org-babel-execute-src-block'."
(message cmd) (shell-command cmd)
nil)) ;; signal that output has already been written to file
-(defun org-babel-prep-session:asymptote (session params)
+(defun org-babel-prep-session:asymptote (_session _params)
"Return an error if the :session header argument is set.
Asymptote does not support sessions"
(error "Asymptote does not support sessions"))
@@ -87,7 +83,7 @@ Asymptote does not support sessions"
(defun org-babel-variable-assignments:asymptote (params)
"Return list of asymptote statements assigning the block's variables."
(mapcar #'org-babel-asymptote-var-to-asymptote
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
(defun org-babel-asymptote-var-to-asymptote (pair)
"Convert an elisp value into an Asymptote variable.
@@ -124,21 +120,17 @@ a variable of the same value."
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 `real', if some elements are
-floats, or `int'."
- (let* ((type 'int)
- find-type ; for byte-compiler
- (find-type
- (function
- (lambda (row)
- (catch 'exit
- (mapc (lambda (el)
- (cond ((listp el) (funcall find-type el))
- ((stringp el) (throw 'exit (setq type 'string)))
- ((floatp el) (setq type 'real))))
- row))))))
- (funcall find-type data) type))
+The type is `string' if any element in DATA is a string.
+Otherwise, it is either `real', if some elements are floats, or
+`int'."
+ (letrec ((type 'int)
+ (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 'real)))))))
+ (catch 'exit (funcall find-type data)) type))
(provide 'ob-asymptote)
diff --git a/lisp/ob-awk.el b/lisp/ob-awk.el
index 021dd78..90cfe79 100644
--- a/lisp/ob-awk.el
+++ b/lisp/ob-awk.el
@@ -1,4 +1,4 @@
-;;; ob-awk.el --- org-babel functions for awk evaluation
+;;; ob-awk.el --- Babel Functions for Awk -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
@@ -27,13 +27,12 @@
;;
;; - :in-file takes a path to a file of data to be processed by awk
;;
-;; - :stdin takes an Org-mode data or code block reference, the value
-;; of which will be passed to the awk process through STDIN
+;; - :stdin takes an Org data or code block reference, the value of
+;; which will be passed to the awk process through STDIN
;;; Code:
(require 'ob)
(require 'org-compat)
-(eval-when-compile (require 'cl))
(declare-function org-babel-ref-resolve "ob-ref" (ref))
(declare-function orgtbl-to-generic "org-table" (table params))
@@ -44,7 +43,7 @@
(defvar org-babel-awk-command "awk"
"Name of the awk executable command.")
-(defun org-babel-expand-body:awk (body params)
+(defun org-babel-expand-body:awk (body _params)
"Expand BODY according to PARAMS, return the expanded body."
body)
@@ -52,13 +51,13 @@
"Execute a block of Awk code with org-babel. This function is
called by `org-babel-execute-src-block'"
(message "executing Awk source code block")
- (let* ((result-params (cdr (assoc :result-params params)))
- (cmd-line (cdr (assoc :cmd-line params)))
- (in-file (cdr (assoc :in-file params)))
+ (let* ((result-params (cdr (assq :result-params params)))
+ (cmd-line (cdr (assq :cmd-line params)))
+ (in-file (cdr (assq :in-file params)))
(full-body (org-babel-expand-body:awk body params))
(code-file (let ((file (org-babel-temp-file "awk-")))
(with-temp-file file (insert full-body)) file))
- (stdin (let ((stdin (cdr (assoc :stdin params))))
+ (stdin (let ((stdin (cdr (assq :stdin params))))
(when stdin
(let ((tmp (org-babel-temp-file "awk-stdin-"))
(res (org-babel-ref-resolve stdin)))
@@ -71,10 +70,10 @@ called by `org-babel-execute-src-block'"
"-f" code-file cmd-line)
(mapcar (lambda (pair)
(format "-v %s='%s'"
- (cadr pair)
+ (car pair)
(org-babel-awk-var-to-awk
- (cddr pair))))
- (org-babel-get-header params :var))
+ (cdr pair))))
+ (org-babel--get-vars params))
(list in-file))
" ")))
(org-babel-reassemble-table
@@ -91,9 +90,9 @@ called by `org-babel-execute-src-block'"
(with-temp-file tmp (insert results))
(org-babel-import-elisp-from-file tmp)))))
(org-babel-pick-name
- (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defun org-babel-awk-var-to-awk (var &optional sep)
"Return a printed value of VAR suitable for parsing with awk."
diff --git a/lisp/ob-calc.el b/lisp/ob-calc.el
index f5e70de..415cab1 100644
--- a/lisp/ob-calc.el
+++ b/lisp/ob-calc.el
@@ -1,4 +1,4 @@
-;;; ob-calc.el --- org-babel functions for calc code evaluation
+;;; ob-calc.el --- Babel Functions for Calc -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -28,18 +28,18 @@
;;; Code:
(require 'ob)
(require 'calc)
-(unless (featurep 'xemacs)
- (require 'calc-trail)
- (require 'calc-store))
+(require 'calc-trail)
+(require 'calc-store)
(declare-function calc-store-into "calc-store" (&optional var))
(declare-function calc-recall "calc-store" (&optional var))
(declare-function math-evaluate-expr "calc-ext" (x))
+(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-default-header-args:calc nil
"Default arguments for evaluating an calc source block.")
-(defun org-babel-expand-body:calc (body params)
+(defun org-babel-expand-body:calc (body _params)
"Expand BODY according to PARAMS, return the expanded body." body)
(defvar org--var-syms) ; Dynamically scoped from org-babel-execute:calc
@@ -48,7 +48,7 @@
"Execute a block of calc code with Babel."
(unless (get-buffer "*Calculator*")
(save-window-excursion (calc) (calc-quit)))
- (let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (let* ((vars (org-babel--get-vars params))
(org--var-syms (mapcar #'car vars))
(var-names (mapcar #'symbol-name org--var-syms)))
(mapc
@@ -85,15 +85,17 @@
;; parse line into calc objects
(car (math-read-exprs line)))))))))
))))))
- (mapcar #'org-babel-trim
+ (mapcar #'org-trim
(split-string (org-babel-expand-body:calc body params) "[\n\r]"))))
(save-excursion
(with-current-buffer (get-buffer "*Calculator*")
- (calc-eval (calc-top 1)))))
+ (prog1
+ (calc-eval (calc-top 1))
+ (calc-pop 1)))))
(defun org-babel-calc-maybe-resolve-var (el)
(if (consp el)
- (if (and (equal 'var (car el)) (member (cadr el) org--var-syms))
+ (if (and (eq 'var (car el)) (member (cadr el) org--var-syms))
(progn
(calc-recall (cadr el))
(prog1 (calc-top 1)
diff --git a/lisp/ob-clojure.el b/lisp/ob-clojure.el
index 5b023e6..72ea77d 100644
--- a/lisp/ob-clojure.el
+++ b/lisp/ob-clojure.el
@@ -1,4 +1,4 @@
-;;; ob-clojure.el --- org-babel functions for clojure evaluation
+;;; ob-clojure.el --- Babel Functions for Clojure -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -39,15 +39,15 @@
;; web page: http://technomancy.us/126
;;; Code:
+(require 'cl-lib)
(require 'ob)
-(eval-when-compile
- (require 'cl))
(declare-function cider-current-connection "ext:cider-client" (&optional type))
(declare-function cider-current-session "ext:cider-client" ())
(declare-function nrepl-dict-get "ext:nrepl-client" (dict key))
(declare-function nrepl-sync-request:eval "ext:nrepl-client"
(input connection session &optional ns))
+(declare-function org-trim "org" (s &optional keep-lead))
(declare-function slime-eval "ext:slime" (sexp &optional package))
(defvar org-babel-tangle-lang-exts)
@@ -67,18 +67,17 @@
(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)))
- (result-params (cdr (assoc :result-params params)))
+ (let* ((vars (org-babel--get-vars params))
+ (result-params (cdr (assq :result-params params)))
(print-level nil) (print-length nil)
- (body (org-babel-trim
- (if (> (length vars) 0)
- (concat "(let ["
- (mapconcat
- (lambda (var)
- (format "%S (quote %S)" (car var) (cdr var)))
- vars "\n ")
- "]\n" body ")")
- body))))
+ (body (org-trim
+ (if (null vars) (org-trim body)
+ (concat "(let ["
+ (mapconcat
+ (lambda (var)
+ (format "%S (quote %S)" (car var) (cdr var)))
+ vars "\n ")
+ "]\n" body ")")))))
(if (or (member "code" result-params)
(member "pp" result-params))
(format "(clojure.pprint/pprint (do %s))" body)
@@ -88,10 +87,10 @@
"Execute a block of Clojure code with Babel."
(let ((expanded (org-babel-expand-body:clojure body params))
result)
- (case org-babel-clojure-backend
+ (cl-case org-babel-clojure-backend
(cider
(require 'cider)
- (let ((result-params (cdr (assoc :result-params params))))
+ (let ((result-params (cdr (assq :result-params params))))
(setq result
(nrepl-dict-get
(nrepl-sync-request:eval
@@ -108,8 +107,8 @@
(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))
+ (cdr (assq :package params)))))))
+ (org-babel-result-cond (cdr (assq :result-params params))
result
(condition-case nil (org-babel-script-escape result)
(error result)))))
diff --git a/lisp/ob-comint.el b/lisp/ob-comint.el
index 8145d2c..dd696c2 100644
--- a/lisp/ob-comint.el
+++ b/lisp/ob-comint.el
@@ -1,4 +1,4 @@
-;;; ob-comint.el --- org-babel functions for interaction with comint buffers
+;;; ob-comint.el --- Babel Functions for Interaction with Comint Buffers -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -33,9 +33,7 @@
(require 'ob-core)
(require 'org-compat)
(require 'comint)
-(eval-when-compile (require 'cl))
-(declare-function with-parsed-tramp-file-name "tramp" (filename var &rest body))
-(declare-function tramp-flush-directory-property "tramp" (vec directory))
+(require 'tramp)
(defun org-babel-comint-buffer-livep (buffer)
"Check if BUFFER is a comint buffer with a live process."
@@ -53,8 +51,9 @@ executed inside the protection of `save-excursion' and
(error "Buffer %s does not exist or has no process" ,buffer))
(save-match-data
(with-current-buffer ,buffer
- (let ((comint-input-filter (lambda (input) nil)))
- ,@body)))))
+ (save-excursion
+ (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)
@@ -79,7 +78,7 @@ or user `keyboard-quit' during execution of body."
(comint-output-filter-functions
(cons (lambda (text) (setq string-buffer (concat string-buffer text)))
comint-output-filter-functions))
- dangling-text raw)
+ dangling-text)
;; got located, and save dangling text
(goto-char (process-mark (get-buffer-process (current-buffer))))
(let ((start (point))
@@ -107,12 +106,12 @@ or user `keyboard-quit' during execution of body."
(insert dangling-text)
;; remove echo'd FULL-BODY from input
- (if (and ,remove-echo ,full-body
- (string-match
- (replace-regexp-in-string
- "\n" "[\r\n]+" (regexp-quote (or ,full-body "")))
- string-buffer))
- (setq raw (substring string-buffer (match-end 0))))
+ (when (and ,remove-echo ,full-body
+ (string-match
+ (replace-regexp-in-string
+ "\n" "[\r\n]+" (regexp-quote (or ,full-body "")))
+ string-buffer))
+ (setq string-buffer (substring string-buffer (match-end 0))))
(split-string string-buffer comint-prompt-regexp)))))
(def-edebug-spec org-babel-comint-with-output (sexp body))
@@ -145,15 +144,14 @@ Don't return until FILE exists. Code in STRING must ensure that
FILE exists at end of evaluation."
(unless (org-babel-comint-buffer-livep buffer)
(error "Buffer %s does not exist or has no process" buffer))
- (if (file-exists-p file) (delete-file file))
+ (when (file-exists-p file) (delete-file file))
(process-send-string
(get-buffer-process buffer)
(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)
- (with-parsed-tramp-file-name default-directory nil
- (tramp-flush-directory-property v ""))))
+ (when (file-remote-p default-directory)
+ (with-parsed-tramp-file-name default-directory nil
+ (tramp-flush-directory-property v "")))
(while (not (file-exists-p file)) (sit-for (or period 0.25))))
(provide 'ob-comint)
diff --git a/lisp/ob-coq.el b/lisp/ob-coq.el
index 210f1a2..7aea5a6 100644
--- a/lisp/ob-coq.el
+++ b/lisp/ob-coq.el
@@ -1,4 +1,4 @@
-;;; ob-coq.el --- org-babel functions for Coq
+;;; ob-coq.el --- Babel Functions for Coq -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -35,11 +35,12 @@
(declare-function run-coq "ext:coq-inferior.el" (cmd))
(declare-function coq-proc "ext:coq-inferior.el" ())
+(defvar coq-program-name "coqtop"
+ "Name of the coq toplevel to run.")
+
(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))
@@ -70,7 +71,7 @@ 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"))
+ (save-window-excursion (run-coq coq-program-name))
(sit-for 0.1)
(get-buffer org-babel-coq-buffer))
diff --git a/lisp/ob-core.el b/lisp/ob-core.el
index fcd15c4..3cfe726 100644
--- a/lisp/ob-core.el
+++ b/lisp/ob-core.el
@@ -1,4 +1,4 @@
-;;; ob-core.el --- working with code blocks in org-mode
+;;; ob-core.el --- Working with Code Blocks -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -23,8 +23,7 @@
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Code:
-(eval-when-compile
- (require 'cl))
+(require 'cl-lib)
(require 'ob-eval)
(require 'org-macs)
(require 'org-compat)
@@ -34,79 +33,69 @@
".exe"
nil))
-;; dynamically scoped for tramp
-(defvar org-babel-call-process-region-original nil)
(defvar org-babel-library-of-babel)
(defvar org-edit-src-content-indentation)
(defvar org-src-lang-modes)
+(defvar org-src-preserve-indentation)
-(declare-function outline-show-all "outline" ())
-(declare-function org-every "org" (pred seq))
-(declare-function org-get-indentation "org" (&optional line))
-(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"
- (filename &optional dir-flag))
-(declare-function tramp-dissect-file-name "tramp" (name &optional nodefault))
-(declare-function tramp-file-name-user "tramp" (vec))
-(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-at-item-p "org-list" ())
+(declare-function org-at-table-p "org" (&optional table-type))
+(declare-function org-babel-lob-execute-maybe "ob-lob" ())
+(declare-function org-babel-ref-goto-headline-id "ob-ref" (id))
+(declare-function org-babel-ref-headline-body "ob-ref" ())
+(declare-function org-babel-ref-parse "ob-ref" (assignment))
+(declare-function org-babel-ref-resolve "ob-ref" (ref))
+(declare-function org-babel-ref-split-args "ob-ref" (arg-string))
+(declare-function org-babel-tangle-comment-links "ob-tangle" (&optional info))
+(declare-function org-completing-read "org" (&rest args))
+(declare-function org-current-level "org" ())
+(declare-function org-cycle "org" (&optional arg))
+(declare-function org-do-remove-indentation "org" (&optional n))
(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))
-(declare-function org-set-outline-overlay-data "org" (data))
-(declare-function org-narrow-to-subtree "org" ())
-(declare-function org-split-string "org" (string &optional separators))
-(declare-function org-entry-get "org"
- (pom property &optional inherit literal-nil))
+(declare-function org-element-at-point "org-element" ())
+(declare-function org-element-context "org-element" (&optional element))
+(declare-function org-element-normalize-string "org-element" (s))
+(declare-function org-element-property "org-element" (property element))
+(declare-function org-element-type "org-element" (element))
+(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
+(declare-function org-escape-code-in-region "org-src" (beg end))
+(declare-function org-get-indentation "org" (&optional line))
+(declare-function org-get-indentation "org" (&optional line))
+(declare-function org-in-regexp "org" (regexp &optional nlines visually))
+(declare-function org-indent-line "org" ())
+(declare-function org-list-get-list-end "org-list" (item struct prevs))
+(declare-function org-list-prevs-alist "org-list" (struct))
+(declare-function org-list-struct "org-list" ())
+(declare-function org-list-to-generic "org-list" (LIST PARAMS))
+(declare-function org-list-to-lisp "org-list" (&optional delete))
+(declare-function org-macro-escape-arguments "org-macro" (&rest args))
(declare-function org-make-options-regexp "org" (kwds &optional extra))
-(declare-function org-do-remove-indentation "org" (&optional n))
+(declare-function org-mark-ring-push "org" (&optional pos buffer))
+(declare-function org-narrow-to-subtree "org" ())
(declare-function org-next-block "org" (arg &optional backward block-regexp))
+(declare-function org-number-sequence "org-compat" (from &optional to inc))
+(declare-function org-open-at-point "org" (&optional in-emacs reference-buffer))
+(declare-function org-outline-overlay-data "org" (&optional use-markers))
(declare-function org-previous-block "org" (arg &optional block-regexp))
+(declare-function org-remove-indentation "org" (code &optional n))
+(declare-function org-reverse-string "org" (string))
+(declare-function org-set-outline-overlay-data "org" (data))
(declare-function org-show-context "org" (&optional key))
-(declare-function org-at-table-p "org" (&optional table-type))
-(declare-function org-cycle "org" (&optional arg))
-(declare-function org-uniquify "org" (list))
-(declare-function org-current-level "org" ())
-(declare-function org-table-import "org-table" (file arg))
-(declare-function org-add-hook "org-compat"
- (hook function &optional append local))
+(declare-function org-split-string "org" (string &optional separators))
+(declare-function org-src-coderef-format "org-src" (element))
+(declare-function org-src-coderef-regexp "org-src" (fmt &optional label))
(declare-function org-table-align "org-table" ())
(declare-function org-table-end "org-table" (&optional table-type))
+(declare-function org-table-import "org-table" (file arg))
+(declare-function org-table-to-lisp "org-table" (&optional txt))
+(declare-function org-trim "org" (s &optional keep-lead))
+(declare-function org-unescape-code-in-string "org-src" (s))
+(declare-function org-uniquify "org" (list))
(declare-function orgtbl-to-generic "org-table" (table params))
(declare-function orgtbl-to-orgtbl "org-table" (table params))
-(declare-function org-babel-tangle-comment-links "ob-tangle" (&optional info))
-(declare-function org-babel-lob-get-info "ob-lob" nil)
-(declare-function org-babel-ref-split-args "ob-ref" (arg-string))
-(declare-function org-babel-ref-parse "ob-ref" (assignment))
-(declare-function org-babel-ref-resolve "ob-ref" (ref))
-(declare-function org-babel-ref-goto-headline-id "ob-ref" (id))
-(declare-function org-babel-ref-headline-body "ob-ref" ())
-(declare-function org-babel-lob-execute-maybe "ob-lob" ())
-(declare-function org-number-sequence "org-compat" (from &optional to inc))
-(declare-function org-at-item-p "org-list" ())
-(declare-function org-list-parse-list "org-list" (&optional delete))
-(declare-function org-list-to-generic "org-list" (LIST PARAMS))
-(declare-function org-list-struct "org-list" ())
-(declare-function org-list-prevs-alist "org-list" (struct))
-(declare-function org-list-get-list-end "org-list" (item struct prevs))
-(declare-function org-remove-if "org" (predicate seq))
-(declare-function org-completing-read "org" (&rest args))
-(declare-function org-escape-code-in-region "org-src" (beg end))
-(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-type "org-element" (element))
-(declare-function org-element-at-point "org-element" ())
-(declare-function org-element-normalize-string "org-element" (s))
-(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))
+(declare-function outline-show-all "outline" ())
+(declare-function tramp-compat-make-temp-file "tramp-compat" (filename &optional dir-flag))
(defgroup org-babel nil
"Code block evaluation and management in `org-mode' documents."
@@ -117,10 +106,10 @@
"Confirm before evaluation.
\\<org-mode-map>\
Require confirmation before interactively evaluating code
-blocks in Org-mode buffers. The default value of this variable
-is t, meaning confirmation is required for any code block
-evaluation. This variable can be set to nil to inhibit any
-future confirmation requests. This variable can also be set to a
+blocks in Org buffers. The default value of this variable is t,
+meaning confirmation is required for any code block evaluation.
+This variable can be set to nil to inhibit any future
+confirmation requests. This variable can also be set to a
function which takes two arguments the language of the code block
and the body of the code block. Such a function should then
return a non-nil value if the user should be prompted for
@@ -128,11 +117,11 @@ execution or nil if no prompt is required.
Warning: Disabling confirmation may result in accidental
evaluation of potentially harmful code. It may be advisable
-remove code block execution from \\[org-ctrl-c-ctrl-c] \
+remove code block execution from `\\[org-ctrl-c-ctrl-c]' \
as further protection
against accidental code block evaluation. The
`org-babel-no-eval-on-ctrl-c-ctrl-c' variable can be used to
-remove code block execution from the \\[org-ctrl-c-ctrl-c] keybinding."
+remove code block execution from the `\\[org-ctrl-c-ctrl-c]' keybinding."
:group 'org-babel
:version "24.1"
:type '(choice boolean function))
@@ -141,7 +130,7 @@ remove code block execution from the \\[org-ctrl-c-ctrl-c] keybinding."
(defcustom org-babel-no-eval-on-ctrl-c-ctrl-c nil
"\\<org-mode-map>\
-Remove code block evaluation from the \\[org-ctrl-c-ctrl-c] key binding."
+Remove code block evaluation from the `\\[org-ctrl-c-ctrl-c]' key binding."
:group 'org-babel
:version "24.1"
:type 'boolean)
@@ -182,6 +171,14 @@ This string must include a \"%s\" which will be replaced by the results."
(and (stringp value)
(string-match-p "%s" value))))
+(defcustom org-babel-hash-show-time nil
+ "Non-nil means show the time the code block was evaluated in the result hash."
+ :group 'org-babel
+ :type 'boolean
+ :version "25.2"
+ :package-version '(Org . "9.0")
+ :safe #'booleanp)
+
(defun org-babel-noweb-wrap (&optional regexp)
(concat org-babel-noweb-wrap-start
(or regexp "\\([^ \t\n].+?[^ \t]\\|[^ \t\n]\\)")
@@ -207,167 +204,100 @@ This string must include a \"%s\" which will be replaced by the results."
"\\([^\000]*?\n\\)??[ \t]*#\\+end_src")
"Regexp used to identify code blocks.")
-(defvar org-babel-inline-src-block-regexp
- (concat
- ;; (1) replacement target (2) lang
- "\\(?:^\\|[^-[: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.")
-
-(defun org-babel-get-header (params key &optional others)
- "Select only header argument of type KEY from a list.
-Optional argument OTHERS indicates that only the header that do
-not match KEY should be returned."
- (delq nil
- (mapcar
- (lambda (p) (when (funcall (if others #'not #'identity) (eq (car p) key)) p))
- params)))
-
-(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"
- (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 ()
- "Set match data if on line of an lob one liner.
-Returns non-nil if match-data set"
- (save-excursion
- (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)))
+(defun org-babel--get-vars (params)
+ "Return the babel variable assignments in PARAMS.
-(defun org-babel-get-src-block-info (&optional light)
- "Get information on the current source block.
-
-Optional argument LIGHT does not resolve remote variable
-references; a process which could likely result in the execution
-of other code blocks.
-
-Returns a list
- (language body header-arguments-alist switches name indent block-head)."
- (let ((case-fold-search t) head info name indent)
- ;; full code block
- (if (setq head (org-babel-where-is-src-block-head))
- (save-excursion
- (goto-char head)
- (setq info (org-babel-parse-src-block-match))
- (setq indent (car (last info)))
- (setq info (butlast info))
- (while (and (= 0 (forward-line -1))
- (looking-at org-babel-multi-line-header-regexp))
- (setf (nth 2 info)
- (org-babel-merge-params
- (nth 2 info)
- (org-babel-parse-header-arguments (match-string 1)))))
- (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)))))
+PARAMS is a quasi-alist of header args, whcih may contain
+multiple entries for the key `:var'. This function returns a
+list of the cdr of all the `:var' entries."
+ (mapcar #'cdr
+ (cl-remove-if-not (lambda (x) (eq (car x) :var)) params)))
(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.
-
-Specifically; NOEVAL will indicate if evaluation is allowed,
-QUERY will indicate if a user query is required, CODE-BLOCK will
-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 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-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)
- (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) " ")))
- ;; Silence byte-compiler if `body' doesn't use those vars.
- (ignore noeval query)
- ,@body)))
-
-(defsubst org-babel-check-evaluate (info)
+(defun org-babel-check-confirm-evaluate (info)
+ "Check whether INFO allows code block evaluation.
+
+Returns nil if evaluation is disallowed, t if it is
+unconditionally allowed, and the symbol `query' if the user
+should be asked whether to allow evaluation."
+ (let* ((headers (nth 2 info))
+ (eval (or (cdr (assq :eval headers))
+ (when (assq :noeval headers) "no")))
+ (eval-no (member eval '("no" "never")))
+ (export org-babel-exp-reference-buffer)
+ (eval-no-export (and export (member eval '("no-export" "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)
+ (save-excursion
+ (goto-char (nth 5 info))
+ (funcall org-confirm-babel-evaluate
+ ;; language, code block body
+ (nth 0 info) (nth 1 info)))
+ org-confirm-babel-evaluate))))
+ (cond
+ (noeval nil)
+ (query 'query)
+ (t t))))
+
+(defun org-babel-check-evaluate (info)
"Check if code block INFO should be evaluated.
-Do not query the user."
- (org-babel-check-confirm-evaluate info
- (not (when noeval
- (message "Evaluation of this%scode-block%sis disabled."
- code-block block-name)))))
- ;; dynamically scoped for asynchronous export
+Do not query the user, but do display an informative message if
+evaluation is blocked. Returns non-nil if evaluation is not blocked."
+ (let ((evalp (org-babel-check-confirm-evaluate info)))
+ (when (null evalp)
+ (message "Evaluation of this %s code-block%sis disabled."
+ (nth 0 info)
+ (let ((name (nth 4 info))) (if name (format " (%s) " name) ""))))
+ evalp))
+
+;; Dynamically scoped for asynchronous export.
(defvar org-babel-confirm-evaluate-answer-no)
-(defsubst org-babel-confirm-evaluate (info)
+(defun org-babel-confirm-evaluate (info)
"Confirm evaluation of the code block INFO.
-If the variable `org-babel-confirm-evaluate-answer-no' is bound
-to a non-nil value, auto-answer with \"no\".
-
This query can also be suppressed by setting the value of
`org-confirm-babel-evaluate' to nil, in which case all future
interactive code block evaluations will proceed without any
confirmation from the user.
Note disabling confirmation may result in accidental evaluation
-of potentially harmful code."
- (org-babel-check-confirm-evaluate info
- (not (when query
- (unless
- (and (not (org-bound-and-true-p
+of potentially harmful code.
+
+The variable `org-babel-confirm-evaluate-answer-no' is used by
+the async export process, which requires a non-interactive
+environment, to override this check."
+ (let* ((evalp (org-babel-check-confirm-evaluate info))
+ (lang (nth 0 info))
+ (name (nth 4 info))
+ (name-string (if name (format " (%s) " name) " ")))
+ (pcase evalp
+ (`nil nil)
+ (`t t)
+ (`query (or
+ (and (not (bound-and-true-p
org-babel-confirm-evaluate-answer-no))
(yes-or-no-p
- (format "Evaluate this%scode block%son your system? "
- code-block block-name)))
- (message "Evaluation of this%scode-block%sis aborted."
- code-block block-name))))))
+ (format "Evaluate this %s code block%son your system? "
+ lang name-string)))
+ (progn
+ (message "Evaluation of this %s code-block%sis aborted."
+ lang name-string)
+ nil)))
+ (x (error "Unexpected value `%s' from `org-babel-check-confirm-evaluate'" x)))))
;;;###autoload
(defun org-babel-execute-safely-maybe ()
(unless org-babel-no-eval-on-ctrl-c-ctrl-c
(org-babel-execute-maybe)))
-(add-hook 'org-ctrl-c-ctrl-c-hook 'org-babel-execute-safely-maybe)
-
;;;###autoload
(defun org-babel-execute-maybe ()
(interactive)
@@ -378,8 +308,8 @@ of potentially harmful code."
"Execute BODY if point is in a source block and return t.
Otherwise do nothing and return nil."
- `(if (or (org-babel-where-is-src-block-head)
- (org-babel-get-inline-src-block-matches))
+ `(if (memq (org-element-type (org-element-context))
+ '(inline-src-block src-block))
(progn
,@body
t)
@@ -530,7 +460,7 @@ 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
+ (cl-every
(lambda (pair)
(and (consp pair)
(org-babel-one-header-arg-safe-p pair ,safe-list)))
@@ -550,22 +480,26 @@ For the format of SAFE-LIST, see `org-babel-safe-header-args'."
(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"))
-
-(defvar org-babel-result-regexp
- (concat "^[ \t]*#\\+"
- (regexp-opt org-babel-data-names t)
- "\\(\\[\\("
- ;; FIXME The string below is `org-ts-regexp'
- "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)>"
- " \\)?\\([[:alnum:]]+\\)\\]\\)?\\:[ \t]*")
+(defconst org-babel-name-regexp
+ (format "^[ \t]*#\\+%s:[ \t]*"
+ ;; FIXME: TBLNAME is for backward compatibility.
+ (regexp-opt '("NAME" "TBLNAME")))
+ "Regexp matching a NAME keyword.")
+
+(defconst org-babel-result-regexp
+ (format "^[ \t]*#\\+%s\\(?:\\[\\(?:%s \\)?\\([[:alnum:]]+\\)\\]\\)?:[ \t]*"
+ org-babel-results-keyword
+ ;; <%Y-%m-%d %H:%M:%S>
+ "<\\(?:[0-9]\\{4\\}-[0-1][0-9]-[0-3][0-9] \
+[0-2][0-9]\\(?::[0-5][0-9]\\)\\{2\\}\\)>")
"Regular expression used to match result lines.
If the results are associated with a hash key then the hash will
-be saved in the second match data.")
+be saved in match group 1.")
-(defvar org-babel-result-w-name-regexp
- (concat org-babel-result-regexp
- "\\([^ ()\f\t\n\r\v]+\\)\\((\\(.*\\))\\|\\)"))
+(defconst org-babel-result-w-name-regexp
+ (concat org-babel-result-regexp "\\(?9:[^ \t\n\r\v\f]+\\)")
+ "Regexp matching a RESULTS keyword with a name.
+Name is saved in match group 9.")
(defvar org-babel-min-lines-for-block-output 10
"The minimum number of lines for block output.
@@ -590,9 +524,6 @@ to raise errors for all languages.")
(defvar org-babel-hash-show 4
"Number of initial characters to show of a hidden results hash.")
-(defvar org-babel-hash-show-time nil
- "Non-nil means show the time the code block was evaluated in the result hash.")
-
(defvar org-babel-after-execute-hook nil
"Hook for functions to be called after `org-babel-execute-src-block'")
@@ -609,10 +540,27 @@ match group 9. Other match groups are defined in
(defun org-babel-named-data-regexp-for-name (name)
"This generates a regexp used to match data named NAME."
- (concat org-babel-result-regexp (regexp-quote name) "\\([ \t]\\|$\\)"))
+ (concat org-babel-name-regexp (regexp-quote name) "[ \t]*$"))
+
+(defun org-babel--normalize-body (datum)
+ "Normalize body for element or object DATUM.
+DATUM is a source block element or an inline source block object.
+Remove final newline character and spurious indentation."
+ (let* ((value (org-element-property :value datum))
+ (body (if (string-suffix-p "\n" value)
+ (substring value 0 -1)
+ value)))
+ (cond ((eq (org-element-type datum) 'inline-src-block)
+ ;; Newline characters and indentation in an inline
+ ;; src-block are not meaningful, since they could come from
+ ;; some paragraph filling. Treat them as a white space.
+ (replace-regexp-in-string "\n[ \t]*" " " body))
+ ((or org-src-preserve-indentation
+ (org-element-property :preserve-indent datum))
+ body)
+ (t (org-remove-indentation body)))))
;;; functions
-(defvar call-process-region)
(defvar org-babel-current-src-block-location nil
"Marker pointing to the src block currently being executed.
This may also point to a call line or an inline code block. If
@@ -622,6 +570,56 @@ the outer-most code block.")
(defvar *this*)
+(defun org-babel-get-src-block-info (&optional light datum)
+ "Extract information from a source block or inline source block.
+
+Optional argument LIGHT does not resolve remote variable
+references; a process which could likely result in the execution
+of other code blocks.
+
+By default, consider the block at point. However, when optional
+argument DATUM is provided, extract information from that parsed
+object instead.
+
+Return nil if point is not on a source block. Otherwise, return
+a list with the following pattern:
+
+ (language body arguments switches name start coderef)"
+ (let* ((datum (or datum (org-element-context)))
+ (type (org-element-type datum))
+ (inline (eq type 'inline-src-block)))
+ (when (memq type '(inline-src-block src-block))
+ (let* ((lang (org-element-property :language datum))
+ (lang-headers (intern
+ (concat "org-babel-default-header-args:" lang)))
+ (name (org-element-property :name datum))
+ (info
+ (list
+ lang
+ (org-babel--normalize-body datum)
+ (apply #'org-babel-merge-params
+ (if inline org-babel-default-inline-header-args
+ org-babel-default-header-args)
+ (and (boundp lang-headers) (eval lang-headers t))
+ (append
+ ;; If DATUM is provided, make sure we get node
+ ;; properties applicable to its location within
+ ;; the document.
+ (org-with-point-at (org-element-property :begin datum)
+ (org-babel-params-from-properties lang))
+ (mapcar #'org-babel-parse-header-arguments
+ (cons (org-element-property :parameters datum)
+ (org-element-property :header datum)))))
+ (or (org-element-property :switches datum) "")
+ name
+ (org-element-property (if inline :begin :post-affiliated)
+ datum)
+ (and (not inline) (org-src-coderef-format datum)))))
+ (unless light
+ (setf (nth 2 info) (org-babel-process-params (nth 2 info))))
+ (setf (nth 2 info) (org-babel-generate-file-param name (nth 2 info)))
+ info))))
+
;;;###autoload
(defun org-babel-execute-src-block (&optional arg info params)
"Execute the current source code block.
@@ -641,114 +639,91 @@ block."
(interactive)
(let* ((org-babel-current-src-block-location
(or org-babel-current-src-block-location
- (nth 6 info)
- (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)))
- (merged-params (org-babel-merge-params (nth 2 info) params)))
- (when (org-babel-check-evaluate
- (let ((i info)) (setf (nth 2 i) merged-params) i))
- (let* ((params (if params
- (org-babel-process-params merged-params)
- (nth 2 info)))
- (cachep (and (not arg) (cdr (assoc :cache params))
- (string= "yes" (cdr (assoc :cache params)))))
- (new-hash (when cachep (org-babel-sha1-hash info)))
- (old-hash (when cachep (org-babel-current-result-hash)))
- (cache-current-p (and (not arg) new-hash
- (equal new-hash old-hash))))
+ (nth 5 info)
+ (org-babel-where-is-src-block-head)))
+ (info (if info (copy-tree info) (org-babel-get-src-block-info))))
+ ;; Merge PARAMS with INFO before considering source block
+ ;; evaluation since both could disagree.
+ (cl-callf org-babel-merge-params (nth 2 info) params)
+ (when (org-babel-check-evaluate info)
+ (cl-callf org-babel-process-params (nth 2 info))
+ (let* ((params (nth 2 info))
+ (cache (let ((c (cdr (assq :cache params))))
+ (and (not arg) c (string= "yes" c))))
+ (new-hash (and cache (org-babel-sha1-hash info)))
+ (old-hash (and cache (org-babel-current-result-hash)))
+ (current-cache (and new-hash (equal new-hash old-hash))))
(cond
- (cache-current-p
- (save-excursion ;; return cached result
+ (current-cache
+ (save-excursion ;Return cached result.
(goto-char (org-babel-where-is-src-block-result nil info))
(forward-line)
(skip-chars-forward " \t")
(let ((result (org-babel-read-result)))
- (message (replace-regexp-in-string
- "%" "%%" (format "%S" result)))
+ (message (replace-regexp-in-string "%" "%%" (format "%S" result)))
result)))
- ((org-babel-confirm-evaluate
- (let ((i info)) (setf (nth 2 i) merged-params) i))
+ ((org-babel-confirm-evaluate info)
(let* ((lang (nth 0 info))
- (result-params (cdr (assoc :result-params params)))
- (body (setf (nth 1 info)
- (if (org-babel-noweb-p params :eval)
- (org-babel-expand-noweb-references info)
- (nth 1 info))))
- (dir (cdr (assoc :dir params)))
+ (result-params (cdr (assq :result-params params)))
+ ;; Expand noweb references in BODY and remove any
+ ;; coderef.
+ (body
+ (let ((coderef (nth 6 info))
+ (expand
+ (if (org-babel-noweb-p params :eval)
+ (org-babel-expand-noweb-references info)
+ (nth 1 info))))
+ (if (not coderef) expand
+ (replace-regexp-in-string
+ (org-src-coderef-regexp coderef) "" expand nil nil 1))))
+ (dir (cdr (assq :dir params)))
(default-directory
(or (and dir (file-name-as-directory (expand-file-name dir)))
default-directory))
- (org-babel-call-process-region-original ;; for tramp handler
- (or (org-bound-and-true-p
- org-babel-call-process-region-original)
- (symbol-function 'call-process-region)))
- (indent (nth 5 info))
- result cmd)
- (unwind-protect
- (let ((call-process-region
- (lambda (&rest args)
- (apply 'org-babel-tramp-handle-call-process-region
- args))))
- (let ((lang-check
- (lambda (f)
- (let ((f (intern (concat "org-babel-execute:" f))))
- (when (fboundp f) f)))))
- (setq cmd
- (or (funcall lang-check lang)
- (funcall lang-check
- (symbol-name
- (cdr (assoc lang org-src-lang-modes))))
- (error "No org-babel-execute function for %s!"
- lang))))
- (message "executing %s code block%s..."
- (capitalize lang)
- (if (nth 4 info) (format " (%s)" (nth 4 info)) ""))
- (if (member "none" result-params)
- (progn
- (funcall cmd body params)
- (message "result silenced")
- (setq result nil))
- (setq result
- (let ((result (funcall cmd body params)))
- (if (and (eq (cdr (assoc :result-type params))
- 'value)
- (or (member "vector" result-params)
- (member "table" result-params))
- (not (listp result)))
- (list (list result)) result)))
- ;; If non-empty result and :file then write to :file.
- (when (cdr (assoc :file params))
- (when result
- (with-temp-file (cdr (assoc :file params))
- (insert
- (org-babel-format-result
- result (cdr (assoc :sep (nth 2 info)))))))
- (setq result (cdr (assoc :file params))))
- ;; Possibly perform post process provided its appropriate.
- (when (cdr (assoc :post params))
- (let ((*this* (if (cdr (assoc :file params))
- (org-babel-result-to-file
- (cdr (assoc :file params))
- (when (assoc :file-desc params)
- (or (cdr (assoc :file-desc params))
- result)))
- result)))
- (setq result (org-babel-ref-resolve
- (cdr (assoc :post params))))
- (when (cdr (assoc :file params))
- (setq result-params
- (remove "file" result-params)))))
- (org-babel-insert-result
- result result-params info new-hash indent lang))
- (run-hooks 'org-babel-after-execute-hook)
- result)
- (setq call-process-region
- 'org-babel-call-process-region-original)))))))))
+ (cmd (intern (concat "org-babel-execute:" lang)))
+ result)
+ (unless (fboundp cmd)
+ (error "No org-babel-execute function for %s!" lang))
+ (message "executing %s code block%s..."
+ (capitalize lang)
+ (let ((name (nth 4 info)))
+ (if name (format " (%s)" name) "")))
+ (if (member "none" result-params)
+ (progn (funcall cmd body params)
+ (message "result silenced"))
+ (setq result
+ (let ((r (funcall cmd body params)))
+ (if (and (eq (cdr (assq :result-type params)) 'value)
+ (or (member "vector" result-params)
+ (member "table" result-params))
+ (not (listp r)))
+ (list (list r))
+ r)))
+ (let ((file (cdr (assq :file params))))
+ ;; If non-empty result and :file then write to :file.
+ (when file
+ (when result
+ (with-temp-file file
+ (insert (org-babel-format-result
+ result (cdr (assq :sep params))))))
+ (setq result file))
+ ;; Possibly perform post process provided its
+ ;; appropriate. Dynamically bind "*this*" to the
+ ;; actual results of the block.
+ (let ((post (cdr (assq :post params))))
+ (when post
+ (let ((*this* (if (not file) result
+ (org-babel-result-to-file
+ file
+ (let ((desc (assq :file-desc params)))
+ (and desc (or (cdr desc) result)))))))
+ (setq result (org-babel-ref-resolve post))
+ (when file
+ (setq result-params (remove "file" result-params))))))
+ (org-babel-insert-result
+ result result-params info new-hash lang)))
+ (run-hooks 'org-babel-after-execute-hook)
+ result)))))))
(defun org-babel-expand-body:generic (body params &optional var-lines)
"Expand BODY with PARAMS.
@@ -756,8 +731,8 @@ Expand a block of code with org-babel according to its header
arguments. This generic implementation of body expansion is
called for languages which have not defined their own specific
org-babel-expand-body:lang function."
- (let ((pro (cdr (assoc :prologue params)))
- (epi (cdr (assoc :epilogue params))))
+ (let ((pro (cdr (assq :prologue params)))
+ (epi (cdr (assq :epilogue params))))
(mapconcat #'identity
(append (when pro (list pro))
var-lines
@@ -788,7 +763,7 @@ arguments and pop open the results in a preview buffer."
(org-babel-expand-body:generic
body params (and (fboundp assignments-cmd)
(funcall assignments-cmd params))))))
- (if (org-called-interactively-p 'any)
+ (if (called-interactively-p 'any)
(org-edit-src-code
expanded (concat "*Org-Babel Preview " (buffer-name) "[ " lang " ]*"))
expanded)))
@@ -821,7 +796,7 @@ arguments and pop open the results in a preview buffer."
(dolist (arg-pair new-list)
(let ((header (car arg-pair)))
(setq results
- (cons arg-pair (org-remove-if
+ (cons arg-pair (cl-remove-if
(lambda (pair) (equal header (car pair)))
results))))))
results))
@@ -854,13 +829,13 @@ arguments and pop open the results in a preview buffer."
(interactive)
(let* ((info (org-babel-get-src-block-info 'light))
(lang (car info))
- (begin (nth 6 info))
+ (begin (nth 5 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))))
+ (when (boundp lang-headers) (eval lang-headers t))))
(header-arg (or header-arg
- (org-icompleting-read
+ (completing-read
"Header Arg: "
(mapcar
(lambda (header-spec) (symbol-name (car header-spec)))
@@ -873,7 +848,7 @@ arguments and pop open the results in a preview buffer."
((listp vals)
(mapconcat
(lambda (group)
- (let ((arg (org-icompleting-read
+ (let ((arg (completing-read
"Value: "
(cons "default"
(mapcar #'symbol-name group)))))
@@ -896,7 +871,7 @@ arguments and pop open the results in a preview buffer."
(defun org-babel-enter-header-arg-w-completion (&optional lang)
"Insert header argument appropriate for LANG with completion."
(let* ((lang-headers-var (intern (concat "org-babel-header-args:" lang)))
- (lang-headers (when (boundp lang-headers-var) (eval lang-headers-var)))
+ (lang-headers (when (boundp lang-headers-var) (eval lang-headers-var t)))
(headers-w-values (org-babel-combine-header-arg-lists
org-babel-common-header-args-w-values lang-headers))
(headers (mapcar #'symbol-name (mapcar #'car headers-w-values)))
@@ -927,8 +902,8 @@ session."
(if (org-babel-noweb-p params :eval)
(org-babel-expand-noweb-references info)
(nth 1 info)))))
- (session (cdr (assoc :session params)))
- (dir (cdr (assoc :dir params)))
+ (session (cdr (assq :session params)))
+ (dir (cdr (assq :dir params)))
(default-directory
(or (and dir (file-name-as-directory dir)) default-directory))
(cmd (intern (concat "org-babel-load-session:" lang))))
@@ -948,17 +923,17 @@ the session. Copy the body of the code block to the kill ring."
(lang (nth 0 info))
(body (nth 1 info))
(params (nth 2 info))
- (session (cdr (assoc :session params)))
- (dir (cdr (assoc :dir params)))
+ (session (cdr (assq :session params)))
+ (dir (cdr (assq :dir params)))
(default-directory
(or (and dir (file-name-as-directory dir)) default-directory))
(init-cmd (intern (format "org-babel-%s-initiate-session" lang)))
(prep-cmd (intern (concat "org-babel-prep-session:" lang))))
- (if (and (stringp session) (string= session "none"))
- (error "This block is not using a session!"))
+ (when (and (stringp session) (string= session "none"))
+ (error "This block is not using a session!"))
(unless (fboundp init-cmd)
(error "No org-babel-initiate-session function for %s!" lang))
- (with-temp-buffer (insert (org-babel-trim body))
+ (with-temp-buffer (insert (org-trim body))
(copy-region-as-kill (point-min) (point-max)))
(when arg
(unless (fboundp prep-cmd)
@@ -1013,10 +988,10 @@ Return t if a code block was found at point, nil otherwise."
"Read key sequence and execute the command in edit buffer.
Enter a key sequence to be executed in the language major-mode
edit buffer. For example, TAB will alter the contents of the
-Org-mode code block according to the effect of TAB in the
-language major-mode buffer. For languages that support
-interactive sessions, this can be used to send code from the Org
-buffer to the session for evaluation using the native major-mode
+Org code block according to the effect of TAB in the language
+major mode buffer. For languages that support interactive
+sessions, this can be used to send code from the Org buffer
+to the session for evaluation using the native major mode
evaluation mechanisms."
(interactive "kEnter key-sequence to execute in edit buffer: ")
(org-babel-do-in-edit-buffer
@@ -1050,7 +1025,7 @@ results already exist."
;; file results
(org-open-at-point)
(let ((r (org-babel-format-result
- (org-babel-read-result) (cdr (assoc :sep (nth 2 info))))))
+ (org-babel-read-result) (cdr (assq :sep (nth 2 info))))))
(pop-to-buffer (get-buffer-create "*Org-Babel Results*"))
(delete-region (point-min) (point-max))
(insert r)))
@@ -1121,81 +1096,91 @@ end-body --------- point at the end of the body"
;;;###autoload
(defmacro org-babel-map-inline-src-blocks (file &rest body)
- "Evaluate BODY forms on each inline source-block in FILE.
+ "Evaluate BODY forms on each inline source block in FILE.
If FILE is nil evaluate BODY forms on source blocks in current
buffer."
- (declare (indent 1))
- (let ((tempvar (make-symbol "file")))
+ (declare (indent 1) (debug (form body)))
+ (org-with-gensyms (datum end point tempvar to-be-removed visitedp)
`(let* ((case-fold-search t)
(,tempvar ,file)
- (visited-p (or (null ,tempvar)
+ (,visitedp (or (null ,tempvar)
(get-file-buffer (expand-file-name ,tempvar))))
- (point (point)) to-be-removed)
+ (,point (point))
+ ,to-be-removed)
(save-window-excursion
(when ,tempvar (find-file ,tempvar))
- (setq to-be-removed (current-buffer))
+ (setq ,to-be-removed (current-buffer))
(goto-char (point-min))
- (while (re-search-forward org-babel-inline-src-block-regexp nil t)
- (when (org-babel-active-location-p)
- (goto-char (match-beginning 1))
- (save-match-data ,@body))
- (goto-char (match-end 0))))
- (unless visited-p (kill-buffer to-be-removed))
- (goto-char point))))
-(def-edebug-spec org-babel-map-inline-src-blocks (form body))
-
-(defvar org-babel-lob-one-liner-regexp)
+ (while (re-search-forward "src_\\S-" nil t)
+ (let ((,datum (save-match-data (org-element-context))))
+ (when (eq (org-element-type ,datum) 'inline-src-block)
+ (goto-char (match-beginning 0))
+ (let ((,end (copy-marker (org-element-property :end ,datum))))
+ ,@body
+ (goto-char ,end)
+ (set-marker ,end nil))))))
+ (unless ,visitedp (kill-buffer ,to-be-removed))
+ (goto-char ,point))))
;;;###autoload
(defmacro org-babel-map-call-lines (file &rest body)
"Evaluate BODY forms on each call line in FILE.
If FILE is nil evaluate BODY forms on source blocks in current
buffer."
- (declare (indent 1))
- (let ((tempvar (make-symbol "file")))
- `(let* ((,tempvar ,file)
- (visited-p (or (null ,tempvar)
+ (declare (indent 1) (debug (form body)))
+ (org-with-gensyms (datum end point tempvar to-be-removed visitedp)
+ `(let* ((case-fold-search t)
+ (,tempvar ,file)
+ (,visitedp (or (null ,tempvar)
(get-file-buffer (expand-file-name ,tempvar))))
- (point (point)) to-be-removed)
+ (,point (point))
+ ,to-be-removed)
(save-window-excursion
(when ,tempvar (find-file ,tempvar))
- (setq to-be-removed (current-buffer))
+ (setq ,to-be-removed (current-buffer))
(goto-char (point-min))
- (while (re-search-forward org-babel-lob-one-liner-regexp nil t)
- (when (org-babel-active-location-p)
- (goto-char (match-beginning 1))
- (save-match-data ,@body))
- (goto-char (match-end 0))))
- (unless visited-p (kill-buffer to-be-removed))
- (goto-char point))))
-(def-edebug-spec org-babel-map-call-lines (form body))
+ (while (re-search-forward "call_\\S-\\|^[ \t]*#\\+CALL:" nil t)
+ (let ((,datum (save-match-data (org-element-context))))
+ (when (memq (org-element-type ,datum)
+ '(babel-call inline-babel-call))
+ (goto-char (match-beginning 0))
+ (let ((,end (copy-marker (org-element-property :end ,datum))))
+ ,@body
+ (goto-char ,end)
+ (set-marker ,end nil))))))
+ (unless ,visitedp (kill-buffer ,to-be-removed))
+ (goto-char ,point))))
;;;###autoload
(defmacro org-babel-map-executables (file &rest body)
- (declare (indent 1))
- (let ((tempvar (make-symbol "file"))
- (rx (make-symbol "rx")))
- `(let* ((,tempvar ,file)
- (,rx (concat "\\(" org-babel-src-block-regexp
- "\\|" org-babel-inline-src-block-regexp
- "\\|" org-babel-lob-one-liner-regexp "\\)"))
- (visited-p (or (null ,tempvar)
+ "Evaluate BODY forms on each active Babel code in FILE.
+If FILE is nil evaluate BODY forms on source blocks in current
+buffer."
+ (declare (indent 1) (debug (form body)))
+ (org-with-gensyms (datum end point tempvar to-be-removed visitedp)
+ `(let* ((case-fold-search t)
+ (,tempvar ,file)
+ (,visitedp (or (null ,tempvar)
(get-file-buffer (expand-file-name ,tempvar))))
- (point (point)) to-be-removed)
+ (,point (point))
+ ,to-be-removed)
(save-window-excursion
(when ,tempvar (find-file ,tempvar))
- (setq to-be-removed (current-buffer))
+ (setq ,to-be-removed (current-buffer))
(goto-char (point-min))
- (while (re-search-forward ,rx nil t)
- (when (org-babel-active-location-p)
- (goto-char (match-beginning 1))
- (when (looking-at org-babel-inline-src-block-regexp)
- (forward-char 1))
- (save-match-data ,@body))
- (goto-char (match-end 0))))
- (unless visited-p (kill-buffer to-be-removed))
- (goto-char point))))
-(def-edebug-spec org-babel-map-executables (form body))
+ (while (re-search-forward
+ "\\(call\\|src\\)_\\|^[ \t]*#\\+\\(BEGIN_SRC\\|CALL:\\)" nil t)
+ (let ((,datum (save-match-data (org-element-context))))
+ (when (memq (org-element-type ,datum)
+ '(babel-call inline-babel-call inline-src-block
+ src-block))
+ (goto-char (match-beginning 0))
+ (let ((,end (copy-marker (org-element-property :end ,datum))))
+ ,@body
+ (goto-char ,end)
+ (set-marker ,end nil))))))
+ (unless ,visitedp (kill-buffer ,to-be-removed))
+ (goto-char ,point))))
;;;###autoload
(defun org-babel-execute-buffer (&optional arg)
@@ -1206,7 +1191,8 @@ the current buffer."
(org-babel-eval-wipe-error-buffer)
(org-save-outline-visibility t
(org-babel-map-executables nil
- (if (looking-at org-babel-lob-one-liner-regexp)
+ (if (memq (org-element-type (org-element-context))
+ '(babel-call inline-babel-call))
(org-babel-lob-execute-maybe)
(org-babel-execute-src-block arg)))))
@@ -1275,24 +1261,30 @@ the current subtree."
(nth 2 info))) ":")
expanded))
(hash (sha1 it)))
- (when (org-called-interactively-p 'interactive) (message hash))
+ (when (called-interactively-p 'interactive) (message hash))
hash))))
(defun org-babel-current-result-hash (&optional info)
"Return the current in-buffer hash."
- (org-babel-where-is-src-block-result nil info)
- (org-no-properties (match-string 5)))
+ (let ((result (org-babel-where-is-src-block-result nil info)))
+ (when result
+ (org-with-wide-buffer
+ (goto-char result)
+ (looking-at org-babel-result-regexp)
+ (match-string-no-properties 1)))))
(defun org-babel-set-current-result-hash (hash info)
"Set the current in-buffer hash to HASH."
- (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)
- (mapc #'delete-overlay (overlays-at (point)))
- (replace-match hash nil nil nil 5)
- (goto-char (point-at-bol))
- (org-babel-hide-hash)))
+ (org-with-wide-buffer
+ (goto-char (org-babel-where-is-src-block-result nil info))
+ (looking-at org-babel-result-regexp)
+ (goto-char (match-beginning 1))
+ (mapc #'delete-overlay (overlays-at (point)))
+ (forward-char org-babel-hash-show)
+ (mapc #'delete-overlay (overlays-at (point)))
+ (replace-match hash nil nil nil 1)
+ (beginning-of-line)
+ (org-babel-hide-hash)))
(defun org-babel-hide-hash ()
"Hide the hash in the current results line.
@@ -1301,11 +1293,11 @@ will remain visible."
(add-to-invisibility-spec '(org-babel-hide-hash . t))
(save-excursion
(when (and (re-search-forward org-babel-result-regexp nil t)
- (match-string 5))
- (let* ((start (match-beginning 5))
+ (match-string 1))
+ (let* ((start (match-beginning 1))
(hide-start (+ org-babel-hash-show start))
- (end (match-end 5))
- (hash (match-string 5))
+ (end (match-end 1))
+ (hash (match-string 1))
ov1 ov2)
(setq ov1 (make-overlay start hide-start))
(setq ov2 (make-overlay hide-start end))
@@ -1329,13 +1321,12 @@ the `org-mode-hook'."
"Return the value of the hash at POINT.
\\<org-mode-map>\
The hash is also added as the last element of the kill ring.
-This can be called with \\[org-ctrl-c-ctrl-c]."
+This can be called with `\\[org-ctrl-c-ctrl-c]'."
(interactive)
(let ((hash (car (delq nil (mapcar
(lambda (ol) (overlay-get ol 'babel-hash))
(overlays-at (or point (point))))))))
(when hash (kill-new hash) (message hash))))
-(add-hook 'org-ctrl-c-ctrl-c-hook 'org-babel-hash-at-point)
(defun org-babel-result-hide-spec ()
"Hide portions of results lines.
@@ -1389,15 +1380,15 @@ portions of results lines."
(eq (overlay-get overlay 'invisible)
'org-babel-hide-result))
(overlays-at start)))
- (if (or (not force) (eq force 'off))
- (mapc (lambda (ov)
- (when (member ov org-babel-hide-result-overlays)
- (setq org-babel-hide-result-overlays
- (delq ov org-babel-hide-result-overlays)))
- (when (eq (overlay-get ov 'invisible)
- 'org-babel-hide-result)
- (delete-overlay ov)))
- (overlays-at start)))
+ (when (or (not force) (eq force 'off))
+ (mapc (lambda (ov)
+ (when (member ov org-babel-hide-result-overlays)
+ (setq org-babel-hide-result-overlays
+ (delq ov org-babel-hide-result-overlays)))
+ (when (eq (overlay-get ov 'invisible)
+ 'org-babel-hide-result)
+ (delete-overlay ov)))
+ (overlays-at start)))
(setq ov (make-overlay start end))
(overlay-put ov 'invisible 'org-babel-hide-result)
;; make the block accessible to isearch
@@ -1417,8 +1408,8 @@ portions of results lines."
(add-hook 'org-tab-first-hook 'org-babel-hide-result-toggle-maybe)
;; Remove overlays when changing major mode
(add-hook 'org-mode-hook
- (lambda () (org-add-hook 'change-major-mode-hook
- 'org-babel-show-result-all 'append 'local)))
+ (lambda () (add-hook 'change-major-mode-hook
+ 'org-babel-show-result-all 'append 'local)))
(defvar org-file-properties)
(defun org-babel-params-from-properties (&optional lang)
@@ -1427,21 +1418,6 @@ Return a list of association lists of source block params
specified in the properties of the current outline entry."
(save-match-data
(list
- ;; DEPRECATED header arguments specified as separate property at
- ;; 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.
(org-babel-parse-header-arguments
@@ -1454,54 +1430,6 @@ specified in the properties of the current outline entry."
(concat "header-args:" lang)
'inherit))))))
-(defvar org-src-preserve-indentation) ;; declare defcustom from org-src
-(defun org-babel-parse-src-block-match ()
- "Parse the results from a match of the `org-babel-src-block-regexp'."
- (let* ((block-indentation (string-width (match-string 1)))
- (lang (org-match-string-no-properties 2))
- (lang-headers (intern (concat "org-babel-default-header-args:" lang)))
- (switches (match-string 3))
- (body (let* ((body (org-match-string-no-properties 5))
- (sub-length (- (length body) 1)))
- (if (and (> sub-length 0)
- (string= "\n" (substring body sub-length)))
- (substring body 0 sub-length)
- (or body ""))))
- (preserve-indentation (or org-src-preserve-indentation
- (save-match-data
- (string-match "-i\\>" switches)))))
- (list lang
- ;; get block body less properties, protective commas, and indentation
- (with-temp-buffer
- (save-match-data
- (insert (org-unescape-code-in-string body))
- (unless preserve-indentation (org-do-remove-indentation))
- (buffer-string)))
- (apply #'org-babel-merge-params
- org-babel-default-header-args
- (when (boundp lang-headers) (eval lang-headers))
- (append
- (org-babel-params-from-properties lang)
- (list (org-babel-parse-header-arguments
- (org-no-properties (or (match-string 4) ""))))))
- switches
- block-indentation)))
-
-(defun org-babel-parse-inline-src-block-match ()
- "Parse the results from a match of the `org-babel-inline-src-block-regexp'."
- (let* ((lang (org-no-properties (match-string 2)))
- (lang-headers (intern (concat "org-babel-default-header-args:" lang))))
- (list lang
- (org-unescape-code-in-string (org-no-properties (match-string 5)))
- (apply #'org-babel-merge-params
- org-babel-default-inline-header-args
- (if (boundp lang-headers) (eval lang-headers) nil)
- (append
- (org-babel-params-from-properties lang)
- (list (org-babel-parse-header-arguments
- (org-no-properties (or (match-string 4) ""))))))
- nil)))
-
(defun org-babel-balanced-split (string alts)
"Split STRING on instances of ALTS.
ALTS is a cons of two character options where each option may be
@@ -1540,7 +1468,7 @@ instances of \"[ \t]:\" set ALTS to ((32 9) . 58)."
(let ((last= (lambda (str) (= ch (aref str (1- (length str))))))
(first= (lambda (str) (= ch (aref str 0)))))
(reverse
- (org-reduce (lambda (acc el)
+ (cl-reduce (lambda (acc el)
(let ((head (car acc)))
(if (and head (or (funcall last= head) (funcall first= el)))
(cons (concat head el) (cdr acc))
@@ -1573,7 +1501,7 @@ shown below.
(let (results)
(mapc (lambda (pair)
(if (eq (car pair) :var)
- (mapcar (lambda (v) (push (cons :var (org-babel-trim v)) results))
+ (mapcar (lambda (v) (push (cons :var (org-trim v)) results))
(org-babel-join-splits-near-ch
61 (org-babel-balanced-split (cdr pair) 32)))
(push pair results)))
@@ -1583,38 +1511,39 @@ shown below.
(defun org-babel-process-params (params)
"Expand variables in PARAMS and add summary parameters."
(let* ((processed-vars (mapcar (lambda (el)
- (if (consp (cdr el))
- (cdr el)
- (org-babel-ref-parse (cdr el))))
- (org-babel-get-header params :var)))
- (vars-and-names (if (and (assoc :colname-names params)
- (assoc :rowname-names params))
+ (if (consp el)
+ el
+ (org-babel-ref-parse el)))
+ (org-babel--get-vars params)))
+ (vars-and-names (if (and (assq :colname-names params)
+ (assq :rowname-names params))
(list processed-vars)
(org-babel-disassemble-tables
processed-vars
- (cdr (assoc :hlines params))
- (cdr (assoc :colnames params))
- (cdr (assoc :rownames params)))))
- (raw-result (or (cdr (assoc :results params)) ""))
- (result-params (append
- (split-string (if (stringp raw-result)
- raw-result
- (eval raw-result)))
- (cdr (assoc :result-params params)))))
+ (cdr (assq :hlines params))
+ (cdr (assq :colnames params))
+ (cdr (assq :rownames params)))))
+ (raw-result (or (cdr (assq :results params)) ""))
+ (result-params (delete-dups
+ (append
+ (split-string (if (stringp raw-result)
+ raw-result
+ (eval raw-result t)))
+ (cdr (assq :result-params params))))))
(append
(mapcar (lambda (var) (cons :var var)) (car vars-and-names))
(list
- (cons :colname-names (or (cdr (assoc :colname-names params))
+ (cons :colname-names (or (cdr (assq :colname-names params))
(cadr vars-and-names)))
- (cons :rowname-names (or (cdr (assoc :rowname-names params))
- (caddr vars-and-names)))
+ (cons :rowname-names (or (cdr (assq :rowname-names params))
+ (cl-caddr vars-and-names)))
(cons :result-params result-params)
(cons :result-type (cond ((member "output" result-params) 'output)
((member "value" result-params) 'value)
(t 'value))))
- (org-remove-if
+ (cl-remove-if
(lambda (x) (memq (car x) '(:colname-names :rowname-names :result-params
- :result-type :var)))
+ :result-type :var)))
params))))
;; row and column names
@@ -1627,7 +1556,7 @@ shown below.
Return a cons cell, the `car' of which contains the TABLE less
colnames, and the `cdr' of which contains a list of the column
names."
- (if (equal 'hline (nth 1 table))
+ (if (eq 'hline (nth 1 table))
(cons (cddr table) (car table))
(cons (cdr table) (car table))))
@@ -1685,7 +1614,7 @@ of the vars, cnames and rnames."
(lambda (var)
(when (listp (cdr var))
(when (and (not (equal colnames "no"))
- (or colnames (and (equal (nth 1 (cdr var)) 'hline)
+ (or colnames (and (eq (nth 1 (cdr var)) 'hline)
(not (member 'hline (cddr (cdr var)))))))
(let ((both (org-babel-get-colnames (cdr var))))
(setq cnames (cons (cons (car var) (cdr both))
@@ -1748,33 +1677,30 @@ If the point is not on a source block then return nil."
(interactive
(let ((completion-ignore-case t)
(case-fold-search t)
- (under-point (thing-at-point 'line)))
- (list (org-icompleting-read
- "source-block name: " (org-babel-src-block-names) nil t
- (cond
- ;; noweb
- ((string-match (org-babel-noweb-wrap) under-point)
- (let ((block-name (match-string 1 under-point)))
- (string-match "[^(]*" block-name)
- (match-string 0 block-name)))
- ;; #+call:
- ((string-match org-babel-lob-one-liner-regexp under-point)
- (let ((source-info (car (org-babel-lob-get-info))))
- (if (string-match "^\\([^\\[]+?\\)\\(\\[.*\\]\\)?(" source-info)
- (let ((source-name (match-string 1 source-info)))
- source-name))))
- ;; #+results:
- ((string-match (concat "#\\+" org-babel-results-keyword
- "\\:\s+\\([^\\(]*\\)") under-point)
- (match-string 1 under-point))
- ;; symbol-at-point
- ((and (thing-at-point 'symbol))
- (org-babel-find-named-block (thing-at-point 'symbol))
- (thing-at-point 'symbol))
- (""))))))
+ (all-block-names (org-babel-src-block-names)))
+ (list (completing-read
+ "source-block name: " all-block-names nil t
+ (let* ((context (org-element-context))
+ (type (org-element-type context))
+ (noweb-ref
+ (and (memq type '(inline-src-block src-block))
+ (org-in-regexp (org-babel-noweb-wrap)))))
+ (cond
+ (noweb-ref
+ (buffer-substring
+ (+ (car noweb-ref) (length org-babel-noweb-wrap-start))
+ (- (cdr noweb-ref) (length org-babel-noweb-wrap-end))))
+ ((memq type '(babel-call inline-babel-call)) ;#+CALL:
+ (org-element-property :call context))
+ ((car (org-element-property :results context))) ;#+RESULTS:
+ ((let ((symbol (thing-at-point 'symbol))) ;Symbol.
+ (and symbol
+ (member-ignore-case symbol all-block-names)
+ symbol)))
+ (t "")))))))
(let ((point (org-babel-find-named-block name)))
(if point
- ;; taken from `org-open-at-point'
+ ;; Taken from `org-open-at-point'.
(progn (org-mark-ring-push) (goto-char point) (org-show-context))
(message "source-code block `%s' not found in this buffer" name))))
@@ -1796,7 +1722,7 @@ to `org-babel-named-src-block-regexp'."
(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))
+ (push (match-string-no-properties 9) names))
names)))
;;;###autoload
@@ -1804,33 +1730,31 @@ to `org-babel-named-src-block-regexp'."
"Go to a named result."
(interactive
(let ((completion-ignore-case t))
- (list (org-icompleting-read "source-block name: "
- (org-babel-result-names) nil t))))
+ (list (completing-read "Source-block name: "
+ (org-babel-result-names) nil t))))
(let ((point (org-babel-find-named-result name)))
(if point
;; taken from `org-open-at-point'
(progn (goto-char point) (org-show-context))
(message "result `%s' not found in this buffer" name))))
-(defun org-babel-find-named-result (name &optional point)
+(defun org-babel-find-named-result (name)
"Find a named result.
Return the location of the result named NAME in the current
buffer or nil if no such result exists."
(save-excursion
- (let ((case-fold-search t))
- (goto-char (or point (point-min)))
- (catch 'is-a-code-block
- (when (re-search-forward
- (concat org-babel-result-regexp
- "[ \t]" (regexp-quote name) "[ \t]*[\n\f\v\r]")
- nil t)
- (when (and (string= "name" (downcase (match-string 1)))
- (or (beginning-of-line 1)
- (looking-at org-babel-src-block-regexp)
- (looking-at org-babel-multi-line-header-regexp)
- (looking-at org-babel-lob-one-liner-regexp)))
- (throw 'is-a-code-block (org-babel-find-named-result name (point))))
- (beginning-of-line 0) (point))))))
+ (goto-char (point-min))
+ (let ((case-fold-search t)
+ (re (format "^[ \t]*#\\+%s.*?:[ \t]*%s[ \t]*$"
+ org-babel-results-keyword
+ (regexp-quote name))))
+ (catch :found
+ (while (re-search-forward re nil t)
+ (let ((element (org-element-at-point)))
+ (when (or (eq (org-element-type element) 'keyword)
+ (< (point)
+ (org-element-property :post-affiliated element)))
+ (throw :found (line-beginning-position)))))))))
(defun org-babel-result-names (&optional file)
"Returns the names of results in FILE or the current buffer."
@@ -1838,7 +1762,7 @@ buffer or nil if no such result exists."
(when file (find-file file)) (goto-char (point-min))
(let ((case-fold-search t) names)
(while (re-search-forward org-babel-result-w-name-regexp nil t)
- (setq names (cons (match-string 4) names)))
+ (setq names (cons (match-string-no-properties 9) names)))
names)))
;;;###autoload
@@ -1883,14 +1807,14 @@ region is not active then the point is demarcated."
(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)))))
+ (string-match-p "#\\+begin_src" block)))))
(if info
(mapc
(lambda (place)
(save-excursion
(goto-char place)
(let ((lang (nth 0 info))
- (indent (make-string (nth 5 info) ? )))
+ (indent (make-string (org-get-indentation) ?\s)))
(when (string-match "^[[:space:]]*$"
(buffer-substring (point-at-bol)
(point-at-eol)))
@@ -1909,7 +1833,7 @@ region is not active then the point is demarcated."
(move-end-of-line 2))
(sort (if (org-region-active-p) (list (mark) (point)) (list (point))) #'>))
(let ((start (point))
- (lang (org-icompleting-read
+ (lang (completing-read
"Lang: "
(mapcar #'symbol-name
(delete-dups
@@ -1924,135 +1848,218 @@ region is not active then the point is demarcated."
lang "\n"
body
(if (or (= (length body) 0)
- (string-match "[\r\n]$" body)) "" "\n")
+ (string-suffix-p "\r" body)
+ (string-suffix-p "\n" body)) "" "\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)
-(defun org-babel-where-is-src-block-result (&optional insert info hash indent)
+(defun org-babel--insert-results-keyword (name hash)
+ "Insert RESULTS keyword with NAME value at point.
+If NAME is nil, results are anonymous. HASH is a string used as
+the results hash, or nil. Leave point before the keyword."
+ (save-excursion (insert "\n")) ;open line to indent.
+ (org-indent-line)
+ (delete-char 1)
+ (insert (concat "#+" org-babel-results-keyword
+ (cond ((not hash) nil)
+ (org-babel-hash-show-time
+ (format "[%s %s]"
+ (format-time-string "<%F %T>")
+ hash))
+ (t (format "[%s]" hash)))
+ ":"
+ (when name (concat " " name))
+ "\n"))
+ ;; Make sure results are going to be followed by at least one blank
+ ;; line so they do not get merged with the next element, e.g.,
+ ;;
+ ;; #+results:
+ ;; : 1
+ ;;
+ ;; : fixed-width area, unrelated to the above.
+ (unless (looking-at "^[ \t]*$") (save-excursion (insert "\n")))
+ (beginning-of-line 0)
+ (when hash (org-babel-hide-hash)))
+
+(defun org-babel--clear-results-maybe (hash)
+ "Clear results when hash doesn't match HASH.
+
+When results hash does not match HASH, remove RESULTS keyword at
+point, along with related contents. Do nothing if HASH is nil.
+
+Return a non-nil value if results were cleared. In this case,
+leave point where new results should be inserted."
+ (when hash
+ (looking-at org-babel-result-regexp)
+ (unless (string= (match-string 1) hash)
+ (let* ((e (org-element-at-point))
+ (post (copy-marker (org-element-property :post-affiliated e))))
+ ;; Delete contents.
+ (delete-region post
+ (save-excursion
+ (goto-char (org-element-property :end e))
+ (skip-chars-backward " \t\n")
+ (line-beginning-position 2)))
+ ;; Delete RESULT keyword. However, if RESULTS keyword is
+ ;; orphaned, ignore this part. The deletion above already
+ ;; took care of it.
+ (unless (= (point) post)
+ (delete-region (line-beginning-position)
+ (line-beginning-position 2)))
+ (goto-char post)
+ (set-marker post nil)
+ t))))
+
+(defun org-babel-where-is-src-block-result (&optional insert _info hash)
"Find where the current source block results begin.
+
Return the point at the beginning of the result of the current
-source block. Specifically at the beginning of the results line.
-If no result exists for this block then create a results line
-following the source block."
- (save-excursion
- (let* ((case-fold-search t)
- (on-lob-line (save-excursion
- (beginning-of-line 1)
- (looking-at org-babel-lob-one-liner-regexp)))
- (inlinep (when (org-babel-get-inline-src-block-matches)
- (match-end 0)))
- (name (nth 4 (or info (org-babel-get-src-block-info 'light))))
- (head (unless on-lob-line (org-babel-where-is-src-block-head)))
- found beg end)
- (when head (goto-char head))
+source block, specifically at the beginning of the results line.
+
+If no result exists for this block return nil, unless optional
+argument INSERT is non-nil. In this case, create a results line
+following the source block and return the position at its
+beginning. In the case of inline code, remove the results part
+instead.
+
+If optional argument HASH is a string, remove contents related to
+RESULTS keyword if its hash is different. Then update the latter
+to HASH."
+ (let ((context (org-element-context)))
+ (catch :found
(org-with-wide-buffer
- (setq
- found ;; was there a result (before we potentially insert one)
- (or
- inlinep
- (and
- ;; named results:
- ;; - return t if it is found, else return nil
- ;; - if it does not need to be rebuilt, then don't set end
- ;; - if it does need to be rebuilt then do set end
- name (setq beg (org-babel-find-named-result name))
- (prog1 beg
- (when (and hash (not (string= hash (match-string 5))))
- (goto-char beg) (setq end beg) ;; beginning of result
- (forward-line 1)
- (delete-region end (org-babel-result-end)) nil)))
- (and
- ;; unnamed results:
- ;; - return t if it is found, else return nil
- ;; - if it is found, and the hash doesn't match, delete and set end
- (or on-lob-line (re-search-forward "^[ \t]*#\\+end_src" nil t))
- (progn (end-of-line 1)
- (if (eobp) (insert "\n") (forward-char 1))
- (setq end (point))
- (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
- (if (looking-at "[\n\r]") (forward-char 1) (insert "\n")))
- (when (wholenump indent) (indent-to indent))
- (insert (concat
- "#+" org-babel-results-keyword
- (when hash
- (if org-babel-hash-show-time
- (concat
- "["(format-time-string "<%Y-%m-%d %H:%M:%S>")" "hash"]")
- (concat "["hash"]")))
- ":"
- (when name (concat " " name)) "\n"))
- (unless beg (insert "\n") (backward-char))
- (beginning-of-line 0)
- (when hash (org-babel-hide-hash))
- (point)))))
-
-(defvar org-block-regexp)
+ (pcase (org-element-type context)
+ ((or `inline-babel-call `inline-src-block)
+ ;; Results for inline objects are located right after them.
+ ;; There is no RESULTS line to insert either.
+ (let ((limit (org-element-property
+ :contents-end (org-element-property :parent context))))
+ (goto-char (org-element-property :end context))
+ (skip-chars-forward " \t\n" limit)
+ (throw :found
+ (and
+ (< (point) limit)
+ (let ((result (org-element-context)))
+ (and (eq (org-element-type result) 'macro)
+ (string= (org-element-property :key result)
+ "results")
+ (if (not insert) (point)
+ (delete-region
+ (point)
+ (progn
+ (goto-char (org-element-property :end result))
+ (skip-chars-backward " \t")
+ (point)))
+ (point))))))))
+ ((or `babel-call `src-block)
+ (let* ((name (org-element-property :name context))
+ (named-results (and name (org-babel-find-named-result name))))
+ (goto-char (or named-results (org-element-property :end context)))
+ (cond
+ ;; Existing results named after the current source.
+ (named-results
+ (when (org-babel--clear-results-maybe hash)
+ (org-babel--insert-results-keyword name hash))
+ (throw :found (point)))
+ ;; Named results expect but none to be found.
+ (name)
+ ;; No possible anonymous results at the very end of
+ ;; buffer or outside CONTEXT parent.
+ ((eq (point)
+ (or (org-element-property
+ :contents-end (org-element-property :parent context))
+ (point-max))))
+ ;; Check if next element is an anonymous result below
+ ;; the current block.
+ ((let* ((next (org-element-at-point))
+ (end (save-excursion
+ (goto-char
+ (org-element-property :post-affiliated next))
+ (line-end-position)))
+ (empty-result-re (concat org-babel-result-regexp "$"))
+ (case-fold-search t))
+ (re-search-forward empty-result-re end t))
+ (beginning-of-line)
+ (when (org-babel--clear-results-maybe hash)
+ (org-babel--insert-results-keyword nil hash))
+ (throw :found (point))))))
+ ;; Ignore other elements.
+ (_ (throw :found nil))))
+ ;; No result found. Insert a RESULTS keyword below element, if
+ ;; appropriate. In this case, ensure there is an empty line
+ ;; after the previous element.
+ (when insert
+ (save-excursion
+ (goto-char (min (org-element-property :end context) (point-max)))
+ (skip-chars-backward " \t\n")
+ (forward-line)
+ (unless (bolp) (insert "\n"))
+ (insert "\n")
+ (org-babel--insert-results-keyword
+ (org-element-property :name context) hash)
+ (point))))))
+
+(defun org-babel-read-element (element)
+ "Read ELEMENT into emacs-lisp.
+Return nil if ELEMENT cannot be read."
+ (org-with-wide-buffer
+ (goto-char (org-element-property :post-affiliated element))
+ (pcase (org-element-type element)
+ (`fixed-width
+ (let ((v (org-trim (org-element-property :value element))))
+ (or (org-babel--string-to-number v) v)))
+ (`table (org-babel-read-table))
+ (`plain-list (org-babel-read-list))
+ (`example-block
+ (let ((v (org-element-property :value element)))
+ (if (or org-src-preserve-indentation
+ (org-element-property :preserve-indent element))
+ v
+ (org-remove-indentation v))))
+ (`export-block
+ (org-remove-indentation (org-element-property :value element)))
+ (`paragraph
+ ;; Treat paragraphs containing a single link specially.
+ (skip-chars-forward " \t")
+ (if (and (looking-at org-bracket-link-regexp)
+ (save-excursion
+ (goto-char (match-end 0))
+ (skip-chars-forward " \r\t\n")
+ (<= (org-element-property :end element)
+ (point))))
+ (org-babel-read-link)
+ (buffer-substring-no-properties
+ (org-element-property :contents-begin element)
+ (org-element-property :contents-end element))))
+ ((or `center-block `quote-block `verse-block `special-block)
+ (org-remove-indentation
+ (buffer-substring-no-properties
+ (org-element-property :contents-begin element)
+ (org-element-property :contents-end element))))
+ (_ nil))))
+
(defun org-babel-read-result ()
- "Read the result at `point' into emacs-lisp."
- (let ((case-fold-search t) result-string)
- (cond
- ((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-remove-indentation (match-string 4)))
- ((or (looking-at "^[ \t]*: ") (looking-at "^[ \t]*:$"))
- (setq result-string
- (org-babel-trim
- (mapconcat (lambda (line)
- (or (and (> (length line) 1)
- (string-match "^[ \t]*: ?\\(.+\\)" line)
- (match-string 1 line))
- ""))
- (split-string
- (buffer-substring
- (point) (org-babel-result-end)) "[\r\n]+")
- "\n")))
- (or (org-babel-number-p result-string) result-string))
- ((looking-at org-babel-result-regexp)
- (save-excursion (forward-line 1) (org-babel-read-result))))))
+ "Read the result at point into emacs-lisp."
+ (and (not (save-excursion
+ (beginning-of-line)
+ (looking-at-p "[ \t]*$")))
+ (org-babel-read-element (org-element-at-point))))
(defun org-babel-read-table ()
- "Read the table at `point' into emacs-lisp."
+ "Read the table at point into emacs-lisp."
(mapcar (lambda (row)
(if (and (symbolp row) (equal row 'hline)) row
(mapcar (lambda (el) (org-babel-read el 'inhibit-lisp-eval)) row)))
(org-table-to-lisp)))
(defun org-babel-read-list ()
- "Read the list at `point' into emacs-lisp."
+ "Read the list at point into emacs-lisp."
(mapcar (lambda (el) (org-babel-read el 'inhibit-lisp-eval))
- (mapcar #'cadr (cdr (org-list-parse-list)))))
+ (cdr (org-list-to-lisp))))
(defvar org-link-types-re)
(defun org-babel-read-link ()
- "Read the link at `point' into emacs-lisp.
+ "Read the link at point into emacs-lisp.
If the path of the link is a file path it is expanded using
`expand-file-name'."
(let* ((case-fold-search t)
@@ -2077,8 +2084,7 @@ If the path of the link is a file path it is expanded using
;; scalar result
(funcall echo-res result))))
-(defun org-babel-insert-result
- (result &optional result-params info hash indent lang)
+(defun org-babel-insert-result (result &optional result-params info hash lang)
"Insert RESULT into the current buffer.
By default RESULT is inserted after the end of the current source
@@ -2094,21 +2100,21 @@ replace - (default option) insert results after the source block
or inline source block replacing any previously
inserted results.
-silent -- no results are inserted into the Org-mode buffer but
+silent -- no results are inserted into the Org buffer but
the results are echoed to the minibuffer and are
ingested by Emacs (a potentially time consuming
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 file syntax.
-list ---- the results are interpreted as an Org-mode list.
+list ---- the results are interpreted as an Org list.
-raw ----- results are added directly to the Org-mode file. This
- is a good option if you code block will output org-mode
+raw ----- results are added directly to the Org file. This is
+ a good option if you code block will output Org
formatted text.
-drawer -- results are added directly to the Org-mode file as with
+drawer -- results are added directly to the Org file as with
\"raw\", but are wrapped in a RESULTS drawer or results
macro, allowing them to later be replaced or removed
automatically.
@@ -2119,15 +2125,16 @@ org ----- results are added inside of a \"src_org{}\" or \"#+BEGIN_SRC
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
+html ---- results are added inside of a #+BEGIN_EXPORT 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.
+latex --- results are added inside of a #+BEGIN_EXPORT 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.
code ---- the results are extracted in the syntax of the source
code of the language being evaluated and are added
@@ -2151,203 +2158,201 @@ INFO may provide the values of these header arguments (in the
:wrap --- the effect is similar to `latex' in RESULT-PARAMS but
using the argument supplied to specify the export block
or snippet type."
-
- (if (stringp result)
- (progn
- (setq result (org-no-properties result))
- (when (member "file" result-params)
- (setq result (org-babel-result-to-file
- result (when (assoc :file-desc (nth 2 info))
- (or (cdr (assoc :file-desc (nth 2 info)))
- result))))))
- (unless (listp result) (setq result (format "%S" result))))
+ (cond ((stringp result)
+ (setq result (org-no-properties result))
+ (when (member "file" result-params)
+ (setq result (org-babel-result-to-file
+ result (when (assq :file-desc (nth 2 info))
+ (or (cdr (assq :file-desc (nth 2 info)))
+ result))))))
+ ((listp result))
+ (t (setq result (format "%S" result))))
(if (and result-params (member "silent" result-params))
- (progn
- (message (replace-regexp-in-string "%" "%%" (format "%S" result)))
- result)
- (save-excursion
- (let* ((inlinep
- (save-excursion
- (when (or (org-babel-get-inline-src-block-matches)
- (org-babel-get-lob-one-liner-matches))
- (goto-char (match-end 0))
- (org-babel-remove-inline-result)
- (insert " ")
- (point))))
- (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 (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.
- (outside-scope-p (and existing-result
+ (progn (message (replace-regexp-in-string "%" "%%" (format "%S" result)))
+ result)
+ (let ((inline (let ((context (org-element-context)))
+ (and (memq (org-element-type context)
+ '(inline-babel-call inline-src-block))
+ context))))
+ (when inline
+ (let ((warning
+ (or (and (member "table" result-params) "`:results table'")
+ (and (listp result) "list result")
+ (and (string-match-p "\n." result) "multiline result")
+ (and (member "list" result-params) "`:results list'"))))
+ (when warning
+ (user-error "Inline error: %s cannot be used" warning))))
+ (save-excursion
+ (let* ((visible-beg (point-min-marker))
+ (visible-end (copy-marker (point-max) t))
+ (inline (let ((context (org-element-context)))
+ (and (memq (org-element-type context)
+ '(inline-babel-call inline-src-block))
+ context)))
+ (existing-result (org-babel-where-is-src-block-result t nil hash))
+ (results-switches (cdr (assq :results_switches (nth 2 info))))
+ ;; When results exist outside of the current visible
+ ;; region of the buffer, be sure to widen buffer to
+ ;; update them.
+ (outside-scope (and existing-result
+ (buffer-narrowed-p)
(or (> visible-beg existing-result)
(<= visible-end existing-result))))
- beg end)
- (when (and (stringp result) ; ensure results end in a newline
- (not inlinep)
- (> (length result) 0)
- (not (or (string-equal (substring result -1) "\n")
- (string-equal (substring result -1) "\r"))))
- (setq result (concat result "\n")))
- (unwind-protect
- (progn
- (when outside-scope-p (widen))
- (if (not existing-result)
- (setq beg (or inlinep (point)))
- (goto-char existing-result)
- (save-excursion
- (re-search-forward "#" nil t)
- (setq indent (- (current-column) 1)))
- (forward-line 1)
+ beg end indent)
+ ;; Ensure non-inline results end in a newline.
+ (when (and (org-string-nw-p result)
+ (not inline)
+ (not (string-equal (substring result -1) "\n")))
+ (setq result (concat result "\n")))
+ (unwind-protect
+ (progn
+ (when outside-scope (widen))
+ (if existing-result (goto-char existing-result)
+ (goto-char (org-element-property :end inline))
+ (skip-chars-backward " \t"))
+ (unless inline
+ (setq indent (org-get-indentation))
+ (forward-line 1))
(setq beg (point))
(cond
+ (inline
+ ;; Make sure new results are separated from the
+ ;; source code by one space.
+ (unless existing-result
+ (insert " ")
+ (setq beg (point))))
((member "replace" result-params)
(delete-region (point) (org-babel-result-end)))
((member "append" result-params)
(goto-char (org-babel-result-end)) (setq beg (point-marker)))
- ((member "prepend" result-params)))) ; already there
- (setq results-switches
- (if results-switches (concat " " results-switches) ""))
- (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)
- (unless no-newlines (goto-char (point-at-eol)))
- (setq end (point-marker))))
- (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.
- ((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
- (org-babel-trim
- (org-list-to-generic
- (cons 'unordered
- (mapcar
- (lambda (el) (list nil (if (stringp el) el (format "%S" el))))
- (if (listp result) result (split-string result "\n" t))))
- '(:splicep nil :istart "- " :iend "\n")))
- "\n"))
- ;; 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 (e)
- (or (eq e 'hline) (listp e)))
- 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)
- (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)))
- (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)))
- nil nil (concat "{{{results(@@" name ":") "@@)}}}")))
- ((member "html" result-params)
- (funcall wrap "#+BEGIN_HTML" "#+END_HTML" nil nil
- "{{{results(@@html:" "@@)}}}"))
- ((member "latex" result-params)
- (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" nil nil
- "{{{results(src_org{" "})}}}"))
- ((member "code" result-params)
- (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 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)))
- (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
- (not (and (listp result)
- (member "append" result-params))))
- (indent-rigidly beg end indent))
- (if (null result)
- (if (member "value" result-params)
- (message "Code block returned no value.")
- (message "Code block produced no output."))
- (message "Code block evaluation complete.")))
- (when outside-scope-p (narrow-to-region visible-beg visible-end))
- (set-marker visible-beg nil)
- (set-marker visible-end nil))))))
+ ((member "prepend" result-params))) ; already there
+ (setq results-switches
+ (if results-switches (concat " " results-switches) ""))
+ (let ((wrap (lambda (start finish &optional no-escape no-newlines
+ inline-start inline-finish)
+ (when inline
+ (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)
+ (unless no-newlines (goto-char (point-at-eol)))
+ (setq end (point-marker))))
+ (tabulablep
+ (lambda (r)
+ ;; Non-nil when result R can be turned into
+ ;; a table.
+ (and (listp r)
+ (null (cdr (last r)))
+ (cl-every
+ (lambda (e) (or (atom e) (null (cdr (last e)))))
+ result)))))
+ ;; insert results based on type
+ (cond
+ ;; Do nothing for an empty result.
+ ((null result))
+ ;; Insert a list if preferred.
+ ((member "list" result-params)
+ (insert
+ (org-trim
+ (org-list-to-generic
+ (cons 'unordered
+ (mapcar
+ (lambda (e)
+ (list (if (stringp e) e (format "%S" e))))
+ (if (listp result) result
+ (split-string result "\n" t))))
+ '(:splicep nil :istart "- " :iend "\n")))
+ "\n"))
+ ;; 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 (cl-every
+ (lambda (e)
+ (or (eq e 'hline) (listp e)))
+ 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 inline
+ (setq result (org-macro-escape-arguments result)))
+ (insert result))
+ ((and inline (not (member "raw" result-params)))
+ (insert (org-macro-escape-arguments
+ (org-babel-chomp result "\n"))))
+ (t (goto-char beg) (insert result)))
+ (setq end (point-marker))
+ ;; possibly wrap result
+ (cond
+ ((assq :wrap (nth 2 info))
+ (let ((name (or (cdr (assq :wrap (nth 2 info))) "RESULTS")))
+ (funcall wrap (concat "#+BEGIN_" name)
+ (concat "#+END_" (car (org-split-string name)))
+ nil nil (concat "{{{results(@@" name ":") "@@)}}}")))
+ ((member "html" result-params)
+ (funcall wrap "#+BEGIN_EXPORT html" "#+END_EXPORT" nil nil
+ "{{{results(@@html:" "@@)}}}"))
+ ((member "latex" result-params)
+ (funcall wrap "#+BEGIN_EXPORT latex" "#+END_EXPORT" nil nil
+ "{{{results(@@latex:" "@@)}}}"))
+ ((member "org" result-params)
+ (goto-char beg) (when (org-at-table-p) (org-cycle))
+ (funcall wrap "#+BEGIN_SRC org" "#+END_SRC" nil nil
+ "{{{results(src_org{" "})}}}"))
+ ((member "code" result-params)
+ (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) (when (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) (when (org-at-table-p) (org-cycle))
+ (funcall wrap ":RESULTS:" ":END:" 'no-escape nil
+ "{{{results(" ")}}}"))
+ ((and inline (member "file" result-params))
+ (funcall wrap nil nil nil nil "{{{results(" ")}}}"))
+ ((and (not (funcall tabulablep result))
+ (not (member "file" result-params)))
+ (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 inline)
+ (setq end (point))))))
+ ;; Possibly indent results in par with #+results line.
+ (when (and (not inline) (numberp indent) (> indent 0)
+ ;; In this case `table-align' does the work
+ ;; for us.
+ (not (and (listp result)
+ (member "append" result-params))))
+ (indent-rigidly beg end indent))
+ (if (null result)
+ (if (member "value" result-params)
+ (message "Code block returned no value.")
+ (message "Code block produced no output."))
+ (message "Code block evaluation complete.")))
+ (when outside-scope (narrow-to-region visible-beg visible-end))
+ (set-marker visible-beg nil)
+ (set-marker visible-end nil)))))))
(defun org-babel-remove-result (&optional info keep-keyword)
"Remove the result of the current source block."
@@ -2361,23 +2366,29 @@ INFO may provide the values of these header arguments (in the
(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 ()
+(defun org-babel-remove-inline-result (&optional datum)
"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."
+Leading white space is trimmed."
(interactive)
- (let* ((el (org-element-context))
- (post-blank (org-element-property :post-blank el)))
+ (let* ((el (or datum (org-element-context))))
(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)))))))))
+ (goto-char (org-element-property :end el))
+ (skip-chars-backward " \t")
+ (let ((result (save-excursion
+ (skip-chars-forward
+ " \t\n"
+ (org-element-property
+ :contents-end (org-element-property :parent el)))
+ (org-element-context))))
+ (when (and (eq (org-element-type result) 'macro)
+ (string= (org-element-property :key result) "results"))
+ (delete-region ; And leading whitespace.
+ (point)
+ (progn (goto-char (org-element-property :end result))
+ (skip-chars-backward " \t\n")
+ (point)))))))))
(defun org-babel-remove-result-one-or-many (x)
"Remove the result of the current source block.
@@ -2427,35 +2438,23 @@ file's directory then expand relative links."
(defvar org-babel-capitalize-example-region-markers nil
"Make true to capitalize begin/end example markers inserted by code blocks.")
-(define-obsolete-function-alias
- 'org-babel-examplize-region
- 'org-babel-examplify-region "25.1")
-
-(defun org-babel-examplify-region (beg end &optional results-switches)
+(defun org-babel-examplify-region (beg end &optional results-switches inline)
"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-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)))
+ (let ((maybe-cap
+ (lambda (str)
+ (if org-babel-capitalize-example-region-markers (upcase str) str))))
+ (if inline
(save-excursion
(goto-char beg)
(insert (format org-babel-inline-result-wrap
- (prog1 (buffer-substring beg end)
- (delete-region beg end)))))
+ (delete-and-extract-region beg end))))
(let ((size (count-lines beg end)))
(save-excursion
(cond ((= size 0)) ; do nothing for an empty result
((< size org-babel-min-lines-for-block-output)
(goto-char beg)
- (dotimes (n size)
+ (dotimes (_ size)
(beginning-of-line 1) (insert ": ") (forward-line 1)))
(t
(goto-char beg)
@@ -2501,144 +2500,103 @@ This takes into account some special considerations for certain
parameters when merging lists."
(let* ((results-exclusive-groups
(mapcar (lambda (group) (mapcar #'symbol-name group))
- (cdr (assoc 'results org-babel-common-header-args-w-values))))
+ (cdr (assq 'results org-babel-common-header-args-w-values))))
(exports-exclusive-groups
(mapcar (lambda (group) (mapcar #'symbol-name group))
- (cdr (assoc 'exports org-babel-common-header-args-w-values))))
- (variable-index 0)
- (e-merge (lambda (exclusive-groups &rest result-params)
- ;; maintain exclusivity of mutually exclusive parameters
- (let (output)
- (mapc (lambda (new-params)
- (mapc (lambda (new-param)
- (mapc (lambda (exclusive-group)
- (when (member new-param exclusive-group)
- (mapcar (lambda (excluded-param)
- (setq output
- (delete
- excluded-param
- output)))
- exclusive-group)))
- exclusive-groups)
- (setq output (org-uniquify
- (cons new-param output))))
- new-params))
- result-params)
- output)))
- params results exports tangle noweb cache vars shebang comments padline
- clearnames)
-
- (mapc
- (lambda (plist)
- (mapc
- (lambda (pair)
- (case (car pair)
- (:var
- (let ((name (if (listp (cdr pair))
- (cadr pair)
- (and (string-match "^\\([^= \f\t\n\r\v]+\\)[ \t]*="
- (cdr pair))
- (intern (match-string 1 (cdr pair)))))))
- (if name
- (setq vars
- (append
- (if (member name (mapcar #'car vars))
- (progn
- (push name clearnames)
- (delq nil
- (mapcar
- (lambda (p)
- (unless (equal (car p) name) p))
- vars)))
- vars)
- (list (cons name pair))))
- ;; if no name is given and we already have named variables
- ;; then assign to named variables in order
- (if (and vars (nth variable-index vars))
- (let ((name (car (nth variable-index vars))))
- (push name clearnames) ; clear out colnames
- ; and rownames
- ; for replace vars
- (prog1 (setf (cddr (nth variable-index vars))
- (concat (symbol-name name) "=" (cdr pair)))
- (incf variable-index)))
- (error "Variable \"%s\" must be assigned a default value"
- (cdr pair))))))
- (:results
- (setq results (funcall e-merge results-exclusive-groups
- results
- (split-string
- (let ((r (cdr pair)))
- (if (stringp r) r (eval r)))))))
- (:file
- (when (cdr pair)
- (setq results (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)))))
- (: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 (or (cdr pair) "")))))
- (:tangle ;; take the latest -- always overwrite
- (setq tangle (or (list (cdr pair)) tangle)))
- (:noweb
- (setq noweb (funcall e-merge
- '(("yes" "no" "tangle" "no-export"
- "strip-export" "eval"))
- noweb
- (split-string (or (cdr pair) "")))))
- (:cache
- (setq cache (funcall e-merge '(("yes" "no")) cache
- (split-string (or (cdr pair) "")))))
- (:padline
- (setq padline (funcall e-merge '(("yes" "no")) padline
- (split-string (or (cdr pair) "")))))
- (:shebang ;; take the latest -- always overwrite
- (setq shebang (or (list (cdr pair)) shebang)))
- (:comments
- (setq comments (funcall e-merge '(("yes" "no")) comments
- (split-string (or (cdr pair) "")))))
- (t ;; replace: this covers e.g. :session
- (setq params (cons pair (assq-delete-all (car pair) params))))))
- plist))
- plists)
- (setq vars (reverse vars))
- (while vars (setq params (cons (cons :var (cddr (pop vars))) params)))
- ;; clear out col-names and row-names for replaced variables
- (mapc
- (lambda (name)
- (mapc
- (lambda (param)
- (when (assoc param params)
- (setf (cdr (assoc param params))
- (org-remove-if (lambda (pair) (equal (car pair) name))
- (cdr (assoc param params))))
- (setf params (org-remove-if (lambda (pair) (and (equal (car pair) param)
- (null (cdr pair))))
- params))))
- (list :colname-names :rowname-names)))
- clearnames)
- (mapc
- (lambda (hd)
- (let ((key (intern (concat ":" (symbol-name hd))))
- (val (eval hd)))
- (setf params (cons (cons key (mapconcat 'identity val " ")) params))))
- '(results exports tangle noweb padline cache shebang comments))
+ (cdr (assq 'exports org-babel-common-header-args-w-values))))
+ (merge
+ (lambda (exclusive-groups &rest result-params)
+ ;; Maintain exclusivity of mutually exclusive parameters,
+ ;; as defined in EXCLUSIVE-GROUPS while merging lists in
+ ;; RESULT-PARAMS.
+ (let (output)
+ (dolist (new-params result-params (delete-dups output))
+ (dolist (new-param new-params)
+ (dolist (exclusive-group exclusive-groups)
+ (when (member new-param exclusive-group)
+ (setq output (cl-remove-if
+ (lambda (o) (member o exclusive-group))
+ output))))
+ (push new-param output))))))
+ (variable-index 0) ;Handle positional arguments.
+ clearnames
+ params ;Final parameters list.
+ ;; Some keywords accept multiple values. We need to treat
+ ;; them specially.
+ vars results exports)
+ (dolist (plist plists)
+ (dolist (pair plist)
+ (pcase pair
+ (`(:var . ,value)
+ (let ((name (cond
+ ((listp value) (car value))
+ ((string-match "^\\([^= \f\t\n\r\v]+\\)[ \t]*=" value)
+ (intern (match-string 1 value)))
+ (t nil))))
+ (cond
+ (name
+ (setq vars
+ (append (if (not (assoc name vars)) vars
+ (push name clearnames)
+ (cl-remove-if (lambda (p) (equal name (car p)))
+ vars))
+ (list (cons name pair)))))
+ ((and vars (nth variable-index vars))
+ ;; If no name is given and we already have named
+ ;; variables then assign to named variables in order.
+ (let ((name (car (nth variable-index vars))))
+ ;; Clear out colnames and rownames for replace vars.
+ (push name clearnames)
+ (setf (cddr (nth variable-index vars))
+ (concat (symbol-name name) "=" value))
+ (cl-incf variable-index)))
+ (t (error "Variable \"%s\" must be assigned a default value"
+ (cdr pair))))))
+ (`(:results . ,value)
+ (setq results (funcall merge
+ results-exclusive-groups
+ results
+ (split-string
+ (if (stringp value) value (eval value t))))))
+ (`(,(or :file :file-ext) . ,value)
+ ;; `:file' and `:file-ext' are regular keywords but they
+ ;; imply a "file" `:results' and a "results" `:exports'.
+ (when value
+ (setq results
+ (funcall merge results-exclusive-groups results '("file")))
+ (unless (or (member "both" exports)
+ (member "none" exports)
+ (member "code" exports))
+ (setq exports
+ (funcall merge
+ exports-exclusive-groups exports '("results"))))
+ (push pair params)))
+ (`(:exports . ,value)
+ (setq exports (funcall merge
+ exports-exclusive-groups
+ exports
+ (split-string (or value "")))))
+ ;; Regular keywords: any value overwrites the previous one.
+ (_ (setq params (cons pair (assq-delete-all (car pair) params)))))))
+ ;; Handle `:var' and clear out colnames and rownames for replaced
+ ;; variables.
+ (setq params (nconc (mapcar (lambda (v) (cons :var (cddr v))) vars)
+ params))
+ (dolist (name clearnames)
+ (dolist (param '(:colname-names :rowname-names))
+ (when (assq param params)
+ (setf (cdr (assq param params))
+ (cl-remove-if (lambda (pair) (equal name (car pair)))
+ (cdr (assq param params))))
+ (setq params
+ (cl-remove-if (lambda (pair) (and (equal (car pair) param)
+ (null (cdr pair))))
+ params)))))
+ ;; Handle other special keywords, which accept multiple values.
+ (setq params (nconc (list (cons :results (mapconcat #'identity results " "))
+ (cons :exports (mapconcat #'identity exports " ")))
+ params))
+ ;; Return merged params.
params))
(defvar org-babel-use-quick-and-dirty-noweb-expansion nil
@@ -2650,17 +2608,12 @@ header argument from buffer or subtree wide properties.")
(defun org-babel-noweb-p (params context)
"Check if PARAMS require expansion in CONTEXT.
CONTEXT may be one of :tangle, :export or :eval."
- (let* (intersect
- (intersect (lambda (as bs)
- (when as
- (if (member (car as) bs)
- (car as)
- (funcall intersect (cdr as) bs))))))
- (funcall intersect (case context
- (:tangle '("yes" "tangle" "no-export" "strip-export"))
- (:eval '("yes" "no-export" "strip-export" "eval"))
- (:export '("yes")))
- (split-string (or (cdr (assoc :noweb params)) "")))))
+ (let ((allowed-values (cl-case context
+ (:tangle '("yes" "tangle" "no-export" "strip-export"))
+ (:eval '("yes" "no-export" "strip-export" "eval"))
+ (:export '("yes")))))
+ (cl-some (lambda (v) (member v allowed-values))
+ (split-string (or (cdr (assq :noweb params)) "")))))
(defun org-babel-expand-noweb-references (&optional info parent-buffer)
"Expand Noweb references in the body of the current source code block.
@@ -2698,7 +2651,7 @@ block but are passed literally to the \"example-block\"."
(body (nth 1 info))
(ob-nww-start org-babel-noweb-wrap-start)
(ob-nww-end org-babel-noweb-wrap-end)
- (comment (string= "noweb" (cdr (assoc :comments (nth 2 info)))))
+ (comment (string= "noweb" (cdr (assq :comments (nth 2 info)))))
(rx-prefix (concat "\\(" org-babel-src-name-regexp "\\|"
":noweb-ref[ \t]+" "\\)"))
(new-body "")
@@ -2707,11 +2660,11 @@ block but are passed literally to the \"example-block\"."
(with-temp-buffer
(funcall (intern (concat lang "-mode")))
(comment-region (point) (progn (insert text) (point)))
- (org-babel-trim (buffer-string)))))
+ (org-trim (buffer-string)))))
index source-name evaluate prefix)
(with-temp-buffer
- (org-set-local 'org-babel-noweb-wrap-start ob-nww-start)
- (org-set-local 'org-babel-noweb-wrap-end ob-nww-end)
+ (setq-local org-babel-noweb-wrap-start ob-nww-start)
+ (setq-local org-babel-noweb-wrap-end ob-nww-end)
(insert body) (goto-char (point-min))
(setq index (point))
(while (and (re-search-forward (org-babel-noweb-wrap) nil t))
@@ -2755,7 +2708,7 @@ block but are passed literally to the \"example-block\"."
(while (re-search-forward rx nil t)
(let* ((i (org-babel-get-src-block-info 'light))
(body (org-babel-expand-noweb-references i))
- (sep (or (cdr (assoc :noweb-sep (nth 2 i)))
+ (sep (or (cdr (assq :noweb-sep (nth 2 i)))
"\n"))
(full (if comment
(let ((cs (org-babel-tangle-comment-links i)))
@@ -2766,11 +2719,11 @@ block but are passed literally to the \"example-block\"."
(setq expansion (cons sep (cons full expansion)))))
(org-babel-map-src-blocks nil
(let ((i (org-babel-get-src-block-info 'light)))
- (when (equal (or (cdr (assoc :noweb-ref (nth 2 i)))
+ (when (equal (or (cdr (assq :noweb-ref (nth 2 i)))
(nth 4 i))
source-name)
(let* ((body (org-babel-expand-noweb-references i))
- (sep (or (cdr (assoc :noweb-sep (nth 2 i)))
+ (sep (or (cdr (assq :noweb-sep (nth 2 i)))
"\n"))
(full (if comment
(let ((cs (org-babel-tangle-comment-links i)))
@@ -2827,7 +2780,7 @@ block but are passed literally to the \"example-block\"."
;; the character was (because one layer of quoting will
;; be stripped by `org-babel-read').
(t (append (list ch ?\\ ?\\) out))))
- (case ch
+ (cl-case ch
(?\[ (if (or in-double in-single)
(cons ?\[ out)
(cons ?\( out)))
@@ -2895,24 +2848,23 @@ 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)
+ (or (org-babel--string-to-number cell)
(if (and (not inhibit-lisp-eval)
(or (member (substring cell 0 1) '("(" "'" "`" "["))
(string= cell "*this*")))
- (eval (read cell))
+ (eval (read cell) t)
(if (string= (substring cell 0 1) "\"")
(read cell)
(progn (set-text-properties 0 (length cell) nil cell) cell))))
cell))
-(defun org-babel-number-p (string)
- "If STRING represents a number return its value."
- (if (and (string-match "[0-9]+" string)
- (string-match "^-?[0-9]*\\.?[0-9]*$" string)
- (= (length (substring string (match-beginning 0)
- (match-end 0)))
- (length string)))
- (string-to-number string)))
+(defun org-babel--string-to-number (string)
+ "If STRING represents a number return its value.
+
+Otherwise return nil."
+ (when (string-match "\\`-?[0-9]*\\.?[0-9]*\\'" string)
+ (string-to-number string)))
+(define-obsolete-function-alias 'org-babel-number-p 'org-babel--string-to-number "Org 9.0")
(defun org-babel-import-elisp-from-file (file-name &optional separator)
"Read the results located at FILE-NAME into an elisp table.
@@ -2953,33 +2905,6 @@ can be specified as the REGEXP argument."
(setq string (substring string 0 -1)))
string))
-(defun org-babel-trim (string &optional 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)
- "Use Tramp to handle `call-process-region'.
-Fixes a bug in `tramp-handle-call-process-region'."
- (if (and (featurep 'tramp) (file-remote-p default-directory))
- (let ((tmpfile (tramp-compat-make-temp-file "")))
- (write-region start end tmpfile)
- (when delete (delete-region start end))
- (unwind-protect
- ;; (apply 'call-process program tmpfile buffer display args)
- ;; bug in tramp
- (apply 'process-file program tmpfile buffer display args)
- (delete-file tmpfile)))
- ;; org-babel-call-process-region-original is the original emacs
- ;; definition. It is in scope from the let binding in
- ;; org-babel-execute-src-block
- (apply org-babel-call-process-region-original
- start end program delete buffer display args)))
-
(defun org-babel-local-file-name (file)
"Return the local name component of FILE."
(or (file-remote-p file 'localname) file))
@@ -3129,15 +3054,42 @@ plus the parameter value."
(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))))
+ "File where a babel block should send graphical output, per PARAMS.
+Return nil if no graphical output is expected. Raise an error if
+the output file is ill-defined."
+ (let ((file (cdr (assq :file params))))
+ (cond (file (and (member "graphics" (cdr (assq :result-params params)))
+ file))
+ ((assq :file-ext params)
+ (user-error ":file-ext given but no :file generated; did you forget \
+to name a block?"))
+ (t (user-error "No :file header argument given; cannot create \
+graphical result")))))
+
+(defun org-babel-make-language-alias (new old)
+ "Make source blocks of type NEW aliases for those of type OLD.
+
+NEW and OLD should be strings. This function should be called
+after the babel API for OLD-type source blocks is fully defined.
+
+Callers of this function will probably want to add an entry to
+`org-src-lang-modes' as well."
+ (dolist (fn '("execute" "expand-body" "prep-session"
+ "variable-assignments" "load-session"))
+ (let ((sym (intern-soft (concat "org-babel-" fn ":" old))))
+ (when (and sym (fboundp sym))
+ (defalias (intern (concat "org-babel-" fn ":" new)) sym))))
+ ;; Technically we don't need a `dolist' for just one variable, but
+ ;; we keep it for symmetry/ease of future expansion.
+ (dolist (var '("default-header-args"))
+ (let ((sym (intern-soft (concat "org-babel-" var ":" old))))
+ (when (and sym (boundp sym))
+ (defvaralias (intern (concat "org-babel-" var ":" new)) sym)))))
+
+(defun org-babel-strip-quotes (string)
+ "Strip \\\"s from around a string, if applicable."
+ (org-unbracket-string "\"" "\"" string))
(provide 'ob-core)
diff --git a/lisp/ob-css.el b/lisp/ob-css.el
index 7f3d81a..5734373 100644
--- a/lisp/ob-css.el
+++ b/lisp/ob-css.el
@@ -1,4 +1,4 @@
-;;; ob-css.el --- org-babel functions for css evaluation
+;;; ob-css.el --- Babel Functions for CSS -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -24,19 +24,19 @@
;;; Commentary:
;; Since CSS can't be executed, this file exists solely for tangling
-;; CSS from org-mode files.
+;; CSS from Org files.
;;; Code:
(require 'ob)
(defvar org-babel-default-header-args:css '())
-(defun org-babel-execute:css (body params)
+(defun org-babel-execute:css (body _params)
"Execute a block of CSS code.
This function is called by `org-babel-execute-src-block'."
body)
-(defun org-babel-prep-session:css (session params)
+(defun org-babel-prep-session:css (_session _params)
"Return an error if the :session header argument is set.
CSS does not support sessions."
(error "CSS sessions are nonsensical"))
diff --git a/lisp/ob-ditaa.el b/lisp/ob-ditaa.el
index 54238f3..1fa96aa 100644
--- a/lisp/ob-ditaa.el
+++ b/lisp/ob-ditaa.el
@@ -1,4 +1,4 @@
-;;; ob-ditaa.el --- org-babel functions for ditaa evaluation
+;;; ob-ditaa.el --- Babel Functions for ditaa -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -81,19 +81,17 @@ Do not leave leading or trailing spaces in this string."
(defun org-babel-execute:ditaa (body params)
"Execute a block of Ditaa code with org-babel.
This function is called by `org-babel-execute-src-block'."
- (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
- (out-file (let ((el (cdr (assoc :file params))))
- (or el
- (error
- "ditaa code block requires :file header argument"))))
- (cmdline (cdr (assoc :cmdline params)))
- (java (cdr (assoc :java params)))
+ (let* ((out-file (or (cdr (assq :file params))
+ (error
+ "ditaa code block requires :file header argument")))
+ (cmdline (cdr (assq :cmdline params)))
+ (java (cdr (assq :java params)))
(in-file (org-babel-temp-file "ditaa-"))
- (eps (cdr (assoc :eps params)))
+ (eps (cdr (assq :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))))
+ (cdr (assq :pdf params))))
(concat
"epstopdf"
" " eps-file
@@ -115,7 +113,7 @@ This function is called by `org-babel-execute-src-block'."
(when pdf-cmd (message pdf-cmd) (shell-command pdf-cmd))
nil)) ;; signal that output has already been written to file
-(defun org-babel-prep-session:ditaa (session params)
+(defun org-babel-prep-session:ditaa (_session _params)
"Return an error because ditaa does not support sessions."
(error "Ditaa does not support sessions"))
diff --git a/lisp/ob-dot.el b/lisp/ob-dot.el
index e2e8857..8cc1c74 100644
--- a/lisp/ob-dot.el
+++ b/lisp/ob-dot.el
@@ -1,4 +1,4 @@
-;;; ob-dot.el --- org-babel functions for dot evaluation
+;;; ob-dot.el --- Babel Functions for dot -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -46,7 +46,7 @@
(defun org-babel-expand-body:dot (body params)
"Expand BODY according to PARAMS, return the expanded body."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
@@ -64,12 +64,11 @@
(defun org-babel-execute:dot (body params)
"Execute a block of Dot code with org-babel.
This function is called by `org-babel-execute-src-block'."
- (let* ((result-params (cdr (assoc :result-params params)))
- (out-file (cdr (or (assoc :file params)
+ (let* ((out-file (cdr (or (assq :file params)
(error "You need to specify a :file parameter"))))
- (cmdline (or (cdr (assoc :cmdline params))
+ (cmdline (or (cdr (assq :cmdline params))
(format "-T%s" (file-name-extension out-file))))
- (cmd (or (cdr (assoc :cmd params)) "dot"))
+ (cmd (or (cdr (assq :cmd params)) "dot"))
(in-file (org-babel-temp-file "dot-")))
(with-temp-file in-file
(insert (org-babel-expand-body:dot body params)))
@@ -80,7 +79,7 @@ This function is called by `org-babel-execute-src-block'."
" -o " (org-babel-process-file-name out-file)) "")
nil)) ;; signal that output has already been written to file
-(defun org-babel-prep-session:dot (session params)
+(defun org-babel-prep-session:dot (_session _params)
"Return an error because Dot does not support sessions."
(error "Dot does not support sessions"))
diff --git a/lisp/ob-ebnf.el b/lisp/ob-ebnf.el
index 9a78f6a..36f2c38 100644
--- a/lisp/ob-ebnf.el
+++ b/lisp/ob-ebnf.el
@@ -1,4 +1,4 @@
-;;; ob-ebnf.el --- org-babel functions for ebnf evaluation
+;;; ob-ebnf.el --- Babel Functions for EBNF -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
@@ -54,13 +54,11 @@
"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)))
+ (let* ((dest-file (cdr (assq :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)
+ (style (cdr (assq :style params)))
(result nil))
(with-temp-buffer
(when style (ebnf-push-style style))
diff --git a/lisp/ob-emacs-lisp.el b/lisp/ob-emacs-lisp.el
index eaa1124..c42034d 100644
--- a/lisp/ob-emacs-lisp.el
+++ b/lisp/ob-emacs-lisp.el
@@ -1,4 +1,4 @@
-;;; ob-emacs-lisp.el --- org-babel functions for emacs-lisp code evaluation
+;;; ob-emacs-lisp.el --- Babel Functions for Emacs-lisp Code -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -28,13 +28,21 @@
;;; Code:
(require 'ob)
-(defvar org-babel-default-header-args:emacs-lisp nil
- "Default arguments for evaluating an emacs-lisp source block.")
+(defconst org-babel-header-args:emacs-lisp '((lexical . :any))
+ "Emacs-lisp specific header arguments.")
+
+(defvar org-babel-default-header-args:emacs-lisp '((:lexical . "no"))
+ "Default arguments for evaluating an emacs-lisp source block.
+
+A value of \"yes\" or t causes src blocks to be eval'd using
+lexical scoping. It can also be an alist mapping symbols to
+their value. It is used as the optional LEXICAL argument to
+`eval', which see.")
(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)))
- (result-params (cdr (assoc :result-params params)))
+ (let* ((vars (org-babel--get-vars params))
+ (result-params (cdr (assq :result-params params)))
(print-level nil) (print-length nil)
(body (if (> (length vars) 0)
(concat "(let ("
@@ -51,26 +59,33 @@
(defun org-babel-execute:emacs-lisp (body params)
"Execute a block of emacs-lisp code with Babel."
(save-window-excursion
- (let ((result
- (eval (read (format (if (member "output"
- (cdr (assoc :result-params params)))
- "(with-output-to-string %s)"
- "(progn %s)")
- (org-babel-expand-body:emacs-lisp
- body params))))))
- (org-babel-result-cond (cdr (assoc :result-params params))
+ (let* ((lexical (cdr (assq :lexical params)))
+ (result
+ (eval (read (format (if (member "output"
+ (cdr (assq :result-params params)))
+ "(with-output-to-string %s)"
+ "(progn %s)")
+ (org-babel-expand-body:emacs-lisp
+ body params)))
+
+ (if (listp lexical)
+ lexical
+ (member lexical '("yes" "t"))))))
+ (org-babel-result-cond (cdr (assq :result-params params))
(let ((print-level nil)
(print-length nil))
- (if (or (member "scalar" (cdr (assoc :result-params params)))
- (member "verbatim" (cdr (assoc :result-params params))))
+ (if (or (member "scalar" (cdr (assq :result-params params)))
+ (member "verbatim" (cdr (assq :result-params params))))
(format "%S" result)
(format "%s" result)))
(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))))))))
+ (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))))))))
+
+(org-babel-make-language-alias "elisp" "emacs-lisp")
(provide 'ob-emacs-lisp)
diff --git a/lisp/ob-eval.el b/lisp/ob-eval.el
index e3ac383..4a368b7 100644
--- a/lisp/ob-eval.el
+++ b/lisp/ob-eval.el
@@ -1,4 +1,4 @@
-;;; ob-eval.el --- org-babel functions for external code evaluation
+;;; ob-eval.el --- Babel Functions for External Code Evaluation -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -28,7 +28,6 @@
;;; Code:
(require 'org-macs)
-(eval-when-compile (require 'cl))
(defvar org-babel-error-buffer-name "*Org-Babel Error Output*")
(declare-function org-babel-temp-file "ob-core" (prefix &optional suffix))
@@ -121,18 +120,18 @@ function in various versions of Emacs.
(delete-file input-file))
(when (and error-file (file-exists-p error-file))
- (if (< 0 (nth 7 (file-attributes error-file)))
- (with-current-buffer (get-buffer-create error-buffer)
- (let ((pos-from-end (- (point-max) (point))))
- (or (bobp)
- (insert "\f\n"))
- ;; Do no formatting while reading error file,
- ;; because that can run a shell command, and we
- ;; don't want that to cause an infinite recursion.
- (format-insert-file error-file nil)
- ;; Put point after the inserted errors.
- (goto-char (- (point-max) pos-from-end)))
- (current-buffer)))
+ (when (< 0 (nth 7 (file-attributes error-file)))
+ (with-current-buffer (get-buffer-create error-buffer)
+ (let ((pos-from-end (- (point-max) (point))))
+ (or (bobp)
+ (insert "\f\n"))
+ ;; Do no formatting while reading error file,
+ ;; because that can run a shell command, and we
+ ;; don't want that to cause an infinite recursion.
+ (format-insert-file error-file nil)
+ ;; Put point after the inserted errors.
+ (goto-char (- (point-max) pos-from-end)))
+ (current-buffer)))
(delete-file error-file))
exit-status))
diff --git a/lisp/ob-exp.el b/lisp/ob-exp.el
index 983d53c..6aebcd5 100644
--- a/lisp/ob-exp.el
+++ b/lisp/ob-exp.el
@@ -1,4 +1,4 @@
-;;; ob-exp.el --- Exportation of org-babel source blocks
+;;; ob-exp.el --- Exportation of Babel Source Blocks -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -24,82 +24,49 @@
;;; Code:
(require 'ob-core)
-(require 'org-src)
-(eval-when-compile
- (require 'cl))
-
-(defvar org-babel-lob-one-liner-regexp)
-(defvar org-babel-ref-split-regexp)
-(defvar org-list-forbidden-blocks)
-
-(declare-function org-babel-lob-get-info "ob-lob" ())
-(declare-function org-babel-eval-wipe-error-buffer "ob-eval" ())
-(declare-function org-between-regexps-p "org"
- (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 avoid-pos stealth))
-(declare-function org-fill-template "org" (template alist))
-(declare-function org-split-string "org" (string &optional separators))
+
+(declare-function org-babel-lob-get-info "ob-lob" (&optional datum))
(declare-function org-element-at-point "org-element" ())
-(declare-function org-element-context "org-element" ())
+(declare-function org-element-context "org-element" (&optional 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))
+(declare-function org-export-copy-buffer "ox" ())
+(declare-function org-fill-template "org" (template alist))
+(declare-function org-get-indentation "org" (&optional line))
+(declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
+
+(defvar org-src-preserve-indentation)
(defcustom org-export-babel-evaluate t
"Switch controlling code evaluation during export.
When set to nil no code will be evaluated as part of the export
-process. When set to `inline-only', only inline code blocks will
-be executed."
+process and no header argumentss will be obeyed. When set to
+`inline-only', only inline code blocks will be executed. Users
+who wish to avoid evaluating code on export should use the header
+argument `:eval never-export'."
:group 'org-babel
:version "24.1"
:type '(choice (const :tag "Never" nil)
(const :tag "Only inline code" inline-only)
(const :tag "Always" t)))
-(put 'org-export-babel-evaluate 'safe-local-variable (lambda (x) (eq x 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-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))
- 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-query
- (condition-case nil
- (let ((org-link-search-inhibit-query t))
- ;; 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-query) nil t)))))
- (setq results ,@body))
- (set-buffer export-buffer)
- results)))
-(def-edebug-spec org-babel-exp-in-export-file (form body))
-
-(defun org-babel-exp-src-block (&rest headers)
+(put 'org-export-babel-evaluate 'safe-local-variable #'null)
+
+(defmacro org-babel-exp--at-source (&rest body)
+ "Evaluate BODY at the source of the Babel block at point.
+Source is located in `org-babel-exp-reference-buffer'. The value
+returned is the value of the last form in BODY. Assume that
+point is at the beginning of the Babel block."
+ (declare (indent 1) (debug body))
+ `(let ((source (get-text-property (point) 'org-reference)))
+ (with-current-buffer org-babel-exp-reference-buffer
+ (org-with-wide-buffer
+ (goto-char source)
+ ,@body))))
+
+(defun org-babel-exp-src-block ()
"Process source block for export.
-Depending on the `export' headers argument, replace the source
+Depending on the \":export\" header argument, replace the source
code block like this:
both ---- display the code and the results
@@ -108,31 +75,36 @@ code ---- the default, display the code inside the block but do
not process
results - just like none only the block is run on export ensuring
- that its results are present in the org-mode buffer
+ that its results are present in the Org mode buffer
none ---- do not display either code or results upon export
-Assume point is at the beginning of block's starting line."
+Assume point is at block opening line."
(interactive)
(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)
+ (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))
+ (message "org-babel-exp process %s at position %d..."
+ lang
+ (line-beginning-position)))
(when info
;; if we're actually going to need the parameters
- (when (member (cdr (assoc :exports (nth 2 info))) '("both" "results"))
- (org-babel-exp-in-export-file lang
- (setf (nth 2 info)
- (org-babel-process-params
- (apply #'org-babel-merge-params
- org-babel-default-header-args
- (if (boundp lang-headers) (eval lang-headers) nil)
- (append (org-babel-params-from-properties lang)
- (list raw-params))))))
+ (when (member (cdr (assq :exports (nth 2 info))) '("both" "results"))
+ (let ((lang-headers (intern (concat "org-babel-default-header-args:"
+ lang))))
+ (org-babel-exp--at-source
+ (setf (nth 2 info)
+ (org-babel-process-params
+ (apply #'org-babel-merge-params
+ org-babel-default-header-args
+ (and (boundp lang-headers)
+ (symbol-value lang-headers))
+ (append (org-babel-params-from-properties lang)
+ (list raw-params)))))))
(setf hash (org-babel-sha1-hash info)))
(org-babel-exp-do-export info 'block hash)))))
@@ -153,182 +125,164 @@ this template."
:group 'org-babel
:type 'string)
-(defvar org-babel-default-lob-header-args)
-(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."
+(defun org-babel-exp-process-buffer ()
+ "Execute all Babel blocks in current buffer."
(interactive)
- (save-window-excursion
- (save-excursion
+ (when org-export-babel-evaluate
+ (save-window-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)
- (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)
- (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.
-Example and verbatim code include escaped portions of
-an org-mode buffer code that should be treated as normal
-org-mode text."
- (or (save-match-data
- (save-excursion
- (goto-char (point-at-bol))
- (looking-at "[ \t]*:[ \t]")))
- (org-in-verbatim-emphasis)
- (org-in-block-p org-list-forbidden-blocks)
- (org-between-regexps-p "^[ \t]*#\\+begin_src" "^[ \t]*#\\+end_src")))
+ (regexp (if (eq org-export-babel-evaluate 'inline-only)
+ "\\(call\\|src\\)_"
+ "\\(call\\|src\\)_\\|^[ \t]*#\\+\\(BEGIN_SRC\\|CALL:\\)"))
+ ;; Get a pristine copy of current buffer so Babel
+ ;; references are properly resolved and source block
+ ;; context is preserved.
+ (org-babel-exp-reference-buffer (org-export-copy-buffer)))
+ (unwind-protect
+ (save-excursion
+ ;; First attach to every source block their original
+ ;; position, so that they can be retrieved within
+ ;; `org-babel-exp-reference-buffer', even after heavy
+ ;; modifications on current buffer.
+ ;;
+ ;; False positives are harmless, so we don't check if
+ ;; we're really at some Babel object. Moreover,
+ ;; `line-end-position' ensures that we propertize
+ ;; a noticeable part of the object, without affecting
+ ;; multiple objects on the same line.
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (let ((s (match-beginning 0)))
+ (put-text-property s (line-end-position) 'org-reference s)))
+ ;; Evaluate from top to bottom every Babel block
+ ;; encountered.
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (unless (save-match-data (org-in-commented-heading-p))
+ (let* ((element (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)))))
+ (pcase type
+ (`inline-src-block
+ (let* ((info
+ (org-babel-get-src-block-info nil element))
+ (params (nth 2 info)))
+ (setf (nth 1 info)
+ (if (and (cdr (assq :noweb params))
+ (string= "yes"
+ (cdr (assq :noweb params))))
+ (org-babel-expand-noweb-references
+ info org-babel-exp-reference-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 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)))))
+ ((or `babel-call `inline-babel-call)
+ (org-babel-exp-do-export (org-babel-lob-get-info element)
+ 'lob)
+ (let ((rep
+ (org-fill-template
+ org-babel-exp-call-line-template
+ `(("line" .
+ ,(org-element-property :value element))))))
+ ;; 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 trailing
+ ;; 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)))
+ ;; Take care of matched block: compute
+ ;; replacement string. In particular, a nil
+ ;; REPLACEMENT means the block is left as-is
+ ;; while an empty string removes the block.
+ (let ((replacement
+ (progn (goto-char match-start)
+ (org-babel-exp-src-block))))
+ (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 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)))))
+ (kill-buffer org-babel-exp-reference-buffer)
+ (remove-text-properties (point-min) (point-max) '(org-reference)))))))
(defun org-babel-exp-do-export (info type &optional hash)
"Return a string with the exported content of a code block.
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)))))
+ (let ((silently (lambda () (let ((session (cdr (assq :session (nth 2 info)))))
+ (unless (equal "none" session)
+ (org-babel-exp-results info type 'silent)))))
(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 type))
- ('results (org-babel-exp-results info type nil hash) "")
- ('both (org-babel-exp-results info type nil hash)
- (org-babel-exp-code info type)))))
+ (org-babel-remove-inline-result)
+ (org-babel-remove-result info)))))
+ (pcase (or (cdr (assq :exports (nth 2 info))) "code")
+ ("none" (funcall silently) (funcall clean) "")
+ ("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 type)))))
(defcustom org-babel-exp-code-template
"#+BEGIN_SRC %lang%switches%flags\n%body\n#+END_SRC"
@@ -369,13 +323,13 @@ 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"
+ :version "25.2"
: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))))
+ (if (string= "strip-export" (cdr (assq :noweb (nth 2 info))))
(replace-regexp-in-string
(org-babel-noweb-wrap) "" (nth 1 info))
(if (org-babel-noweb-p (nth 2 info) :export)
@@ -400,14 +354,11 @@ replaced with its value."
(defun org-babel-exp-results (info type &optional silent hash)
"Evaluate and return the results of the current code block for export.
-Results are prepared in a manner suitable for export by org-mode.
+Results are prepared in a manner suitable for export by Org mode.
This function is called by `org-babel-exp-do-export'. The code
block will be evaluated. Optional argument SILENT can be used to
inhibit insertion of results into the buffer."
- (when (and (or (eq org-export-babel-evaluate t)
- (and (eq type 'inline)
- (eq org-export-babel-evaluate 'inline-only)))
- (not (and hash (equal hash (org-babel-current-result-hash)))))
+ (unless (and hash (equal hash (org-babel-current-result-hash)))
(let ((lang (nth 0 info))
(body (if (org-babel-noweb-p (nth 2 info) :eval)
(org-babel-expand-noweb-references
@@ -415,33 +366,29 @@ inhibit insertion of results into the buffer."
(nth 1 info)))
(info (copy-sequence info))
(org-babel-current-src-block-location (point-marker)))
- ;; skip code blocks which we can't evaluate
+ ;; Skip code blocks which we can't evaluate.
(when (fboundp (intern (concat "org-babel-execute:" lang)))
(org-babel-eval-wipe-error-buffer)
- (prog1 nil
- (setf (nth 1 info) body)
- (setf (nth 2 info)
- (org-babel-exp-in-export-file lang
- (org-babel-process-params
- (org-babel-merge-params
- (nth 2 info)
- `((:results . ,(if silent "silent" "replace")))))))
- (cond
- ((equal type 'block)
+ (setf (nth 1 info) body)
+ (setf (nth 2 info)
+ (org-babel-exp--at-source
+ (org-babel-process-params
+ (org-babel-merge-params
+ (nth 2 info)
+ `((:results . ,(if silent "silent" "replace")))))))
+ (pcase type
+ (`block (org-babel-execute-src-block nil info))
+ (`inline
+ ;; Position the point on the inline source block
+ ;; allowing `org-babel-insert-result' to check that the
+ ;; block is inline.
+ (goto-char (nth 5 info))
(org-babel-execute-src-block nil info))
- ((equal type 'inline)
- ;; position the point on the inline source block allowing
- ;; `org-babel-insert-result' to check that the block is
- ;; inline
- (re-search-backward "[ \f\t\n\r\v]" nil t)
- (re-search-forward org-babel-inline-src-block-regexp nil t)
- (re-search-backward "src_" nil t)
- (org-babel-execute-src-block nil info))
- ((equal type 'lob)
- (save-excursion
- (re-search-backward org-babel-lob-one-liner-regexp nil t)
- (let (org-confirm-babel-evaluate)
- (org-babel-execute-src-block nil info))))))))))
+ (`lob
+ (save-excursion
+ (goto-char (nth 5 info))
+ (let (org-confirm-babel-evaluate)
+ (org-babel-execute-src-block nil info)))))))))
(provide 'ob-exp)
diff --git a/lisp/ob-forth.el b/lisp/ob-forth.el
index 5a46d36..e487931 100644
--- a/lisp/ob-forth.el
+++ b/lisp/ob-forth.el
@@ -1,4 +1,4 @@
-;;; ob-forth.el --- org-babel functions for Forth
+;;; ob-forth.el --- Babel Functions for Forth -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
@@ -35,6 +35,7 @@
(require 'ob)
(declare-function forth-proc "ext:gforth" ())
+(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-default-header-args:forth '((:session . "yes"))
"Default header arguments for forth code blocks.")
@@ -42,10 +43,10 @@
(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)))
+ (if (string= "none" (cdr (assq :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)))
+ (if (member "output" (cdr (assq :result-params params)))
(mapconcat #'identity all-results "\n")
(car (last all-results))))))
@@ -76,10 +77,10 @@ This function is called by `org-babel-execute-src-block'"
(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)))))
+ (split-string (org-trim
+ (org-babel-expand-body:generic body params))
+ "\n"
+ 'omit-nulls)))))
(provide 'ob-forth)
diff --git a/lisp/ob-fortran.el b/lisp/ob-fortran.el
index ed5d2dc..6241c65 100644
--- a/lisp/ob-fortran.el
+++ b/lisp/ob-fortran.el
@@ -1,4 +1,4 @@
-;;; ob-fortran.el --- org-babel functions for fortran
+;;; ob-fortran.el --- Babel Functions for Fortran -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
@@ -29,11 +29,12 @@
;;; Code:
(require 'ob)
(require 'cc-mode)
+(require 'cl-lib)
(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))
+(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("fortran" . "F90"))
@@ -48,44 +49,42 @@
"This function should only be called by `org-babel-execute:fortran'"
(let* ((tmp-src-file (org-babel-temp-file "fortran-src-" ".F90"))
(tmp-bin-file (org-babel-temp-file "fortran-bin-" org-babel-exeext))
- (cmdline (cdr (assoc :cmdline params)))
- (flags (cdr (assoc :flags params)))
- (full-body (org-babel-expand-body:fortran body params))
- (compile
- (progn
- (with-temp-file tmp-src-file (insert full-body))
- (org-babel-eval
- (format "%s -o %s %s %s"
- org-babel-fortran-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)) ""))))
+ (cmdline (cdr (assq :cmdline params)))
+ (flags (cdr (assq :flags params)))
+ (full-body (org-babel-expand-body:fortran body params)))
+ (with-temp-file tmp-src-file (insert full-body))
+ (org-babel-eval
+ (format "%s -o %s %s %s"
+ org-babel-fortran-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)) "")
(let ((results
- (org-babel-trim
+ (org-trim
(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-result-cond (cdr (assq :result-params params))
(org-babel-read results)
(let ((tmp-file (org-babel-temp-file "f-")))
(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)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
(defun org-babel-expand-body:fortran (body params)
"Expand a block of fortran or fortran code with org-babel according to
its 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))
+ (let ((vars (org-babel--get-vars params))
+ (main-p (not (string= (cdr (assq :main params)) "no")))
+ (includes (or (cdr (assq :includes params))
(org-babel-read (org-entry-get nil "includes" t))))
(defines (org-babel-read
- (or (cdr (assoc :defines params))
+ (or (cdr (assq :defines params))
(org-babel-read (org-entry-get nil "defines" t))))))
(mapconcat 'identity
(list
@@ -109,17 +108,17 @@ its header arguments."
(defun org-babel-fortran-ensure-main-wrap (body params)
"Wrap body in a \"program ... end program\" block if none exists."
(if (string-match "^[ \t]*program[ \t]*.*" (capitalize body))
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(if vars (error "Cannot use :vars if `program' statement is present"))
body)
(format "program main\n%s\nend program main\n" body)))
-(defun org-babel-prep-session:fortran (session params)
+(defun org-babel-prep-session:fortran (_session _params)
"This function does nothing as fortran is a compiled language with no
support for sessions"
(error "Fortran is a compiled languages -- no support for sessions"))
-(defun org-babel-load-session:fortran (session body params)
+(defun org-babel-load-session:fortran (_session _body _params)
"This function does nothing as fortran is a compiled language with no
support for sessions"
(error "Fortran is a compiled languages -- no support for sessions"))
@@ -147,7 +146,7 @@ of the same value."
(format "character(len=%d), parameter :: %S = '%s'\n"
(length val) var val))
;; val is a matrix
- ((and (listp val) (org-every #'listp val))
+ ((and (listp val) (cl-every #'listp val))
(format "real, parameter :: %S(%d,%d) = transpose( reshape( %s , (/ %d, %d /) ) )\n"
var (length val) (length (car val))
(org-babel-fortran-transform-list val)
diff --git a/lisp/ob-gnuplot.el b/lisp/ob-gnuplot.el
index 237ecec..e91e05a 100644
--- a/lisp/ob-gnuplot.el
+++ b/lisp/ob-gnuplot.el
@@ -1,4 +1,4 @@
-;;; ob-gnuplot.el --- org-babel functions for gnuplot evaluation
+;;; ob-gnuplot.el --- Babel Functions for Gnuplot -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -39,9 +39,8 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
-(declare-function org-time-string-to-time "org" (s))
+(declare-function org-time-string-to-time "org" (s &optional buffer pos))
(declare-function org-combine-plists "org" (&rest plists))
(declare-function orgtbl-to-generic "org-table" (table params))
(declare-function gnuplot-mode "ext:gnuplot-mode" ())
@@ -80,7 +79,7 @@
Dumps all vectors into files and returns an association list
of variable names and the related value to be used in the gnuplot
code."
- (let ((*org-babel-gnuplot-missing* (cdr (assoc :missing params))))
+ (let ((*org-babel-gnuplot-missing* (cdr (assq :missing params))))
(mapcar
(lambda (pair)
(cons
@@ -94,32 +93,30 @@ code."
(if tablep val (mapcar 'list val)))
(org-babel-temp-file "gnuplot-") params)
val))))
- (mapcar #'cdr (org-babel-get-header params :var)))))
+ (org-babel--get-vars params))))
(defun org-babel-expand-body:gnuplot (body params)
"Expand BODY according to PARAMS, return the expanded body."
(save-window-excursion
(let* ((vars (org-babel-gnuplot-process-vars params))
- (out-file (cdr (assoc :file params)))
- (prologue (cdr (assoc :prologue params)))
- (epilogue (cdr (assoc :epilogue params)))
- (term (or (cdr (assoc :term params))
+ (out-file (cdr (assq :file params)))
+ (prologue (cdr (assq :prologue params)))
+ (epilogue (cdr (assq :epilogue params)))
+ (term (or (cdr (assq :term params))
(when out-file
(let ((ext (file-name-extension out-file)))
(or (cdr (assoc (intern (downcase ext))
*org-babel-gnuplot-terms*))
ext)))))
- (cmdline (cdr (assoc :cmdline params)))
- (title (cdr (assoc :title params)))
- (lines (cdr (assoc :line params)))
- (sets (cdr (assoc :set params)))
- (x-labels (cdr (assoc :xlabels params)))
- (y-labels (cdr (assoc :ylabels params)))
- (timefmt (cdr (assoc :timefmt params)))
- (time-ind (or (cdr (assoc :timeind params))
+ (title (cdr (assq :title params)))
+ (lines (cdr (assq :line params)))
+ (sets (cdr (assq :set params)))
+ (x-labels (cdr (assq :xlabels params)))
+ (y-labels (cdr (assq :ylabels params)))
+ (timefmt (cdr (assq :timefmt params)))
+ (time-ind (or (cdr (assq :timeind params))
(when timefmt 1)))
- (add-to-body (lambda (text) (setq body (concat text "\n" body))))
- output)
+ (add-to-body (lambda (text) (setq body (concat text "\n" body)))))
;; 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))
@@ -171,9 +168,8 @@ code."
"Execute a block of Gnuplot code.
This function is called by `org-babel-execute-src-block'."
(require 'gnuplot)
- (let ((session (cdr (assoc :session params)))
- (result-type (cdr (assoc :results params)))
- (out-file (cdr (assoc :file params)))
+ (let ((session (cdr (assq :session params)))
+ (result-type (cdr (assq :results params)))
(body (org-babel-expand-body:gnuplot body params))
output)
(save-window-excursion
@@ -206,10 +202,12 @@ This function is called by `org-babel-execute-src-block'."
(var-lines (org-babel-variable-assignments:gnuplot params)))
(message "%S" session)
(org-babel-comint-in-buffer session
- (mapc (lambda (var-line)
- (insert var-line) (comint-send-input nil t)
- (org-babel-comint-wait-for-output session)
- (sit-for .1) (goto-char (point-max))) var-lines))
+ (dolist (var-line var-lines)
+ (insert var-line)
+ (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)
+ (sit-for .1)
+ (goto-char (point-max))))
session))
(defun org-babel-load-session:gnuplot (session body params)
@@ -228,7 +226,7 @@ This function is called by `org-babel-execute-src-block'."
(org-babel-gnuplot-process-vars params)))
(defvar gnuplot-buffer)
-(defun org-babel-gnuplot-initiate-session (&optional session params)
+(defun org-babel-gnuplot-initiate-session (&optional session _params)
"Initiate a gnuplot session.
If there is not a current inferior-process-buffer in SESSION
then create one. Return the initialized session. The current
diff --git a/lisp/ob-groovy.el b/lisp/ob-groovy.el
index 14f644c..9578c70 100644
--- a/lisp/ob-groovy.el
+++ b/lisp/ob-groovy.el
@@ -1,4 +1,4 @@
-;;; ob-groovy.el --- org-babel functions for Groovy evaluation
+;;; ob-groovy.el --- Babel Functions for Groovy -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
@@ -31,7 +31,6 @@
;;; 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"))
@@ -51,9 +50,8 @@ 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)))
+ (result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params))
(result (org-babel-groovy-evaluate
@@ -62,9 +60,9 @@ called by `org-babel-execute-src-block'"
(org-babel-reassemble-table
result
(org-babel-pick-name
- (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defvar org-babel-groovy-wrapper-method
@@ -78,19 +76,19 @@ println(new Runner().run())
(defun org-babel-groovy-evaluate
- (session body &optional result-type result-params)
+ (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
+ (pcase 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
+ (`value
(let* ((src-file (org-babel-temp-file "groovy-"))
(wrapper (format org-babel-groovy-wrapper-method body)))
(with-temp-file src-file (insert wrapper))
@@ -101,11 +99,11 @@ in BODY as elisp."
(org-babel-script-escape raw)))))))
-(defun org-babel-prep-session:groovy (session params)
+(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)
+(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."
diff --git a/lisp/ob-haskell.el b/lisp/ob-haskell.el
index e9cb3cc..5dcb516 100644
--- a/lisp/ob-haskell.el
+++ b/lisp/ob-haskell.el
@@ -1,4 +1,4 @@
-;;; ob-haskell.el --- org-babel functions for haskell evaluation
+;;; ob-haskell.el --- Babel Functions for Haskell -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -41,9 +41,9 @@
;;; Code:
(require 'ob)
(require 'comint)
-(eval-when-compile (require 'cl))
(declare-function org-remove-indentation "org" (code &optional n))
+(declare-function org-trim "org" (s &optional keep-lead))
(declare-function haskell-mode "ext:haskell-mode" ())
(declare-function run-haskell "ext:inf-haskell" (&optional arg))
(declare-function inferior-haskell-load-file
@@ -61,42 +61,35 @@
(defun org-babel-execute:haskell (body params)
"Execute a block of Haskell code."
- (let* ((session (cdr (assoc :session params)))
- (vars (mapcar #'cdr (org-babel-get-header params :var)))
- (result-type (cdr (assoc :result-type params)))
+ (let* ((session (cdr (assq :session params)))
+ (result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params
(org-babel-variable-assignments:haskell params)))
(session (org-babel-haskell-initiate-session session params))
(raw (org-babel-comint-with-output
(session org-babel-haskell-eoe t full-body)
- (insert (org-babel-trim full-body))
+ (insert (org-trim full-body))
(comint-send-input nil t)
(insert org-babel-haskell-eoe)
(comint-send-input nil t)))
(results (mapcar
- #'org-babel-haskell-read-string
+ #'org-babel-strip-quotes
(cdr (member org-babel-haskell-eoe
- (reverse (mapcar #'org-babel-trim raw)))))))
+ (reverse (mapcar #'org-trim raw)))))))
(org-babel-reassemble-table
(let ((result
- (case result-type
- (output (mapconcat #'identity (reverse (cdr results)) "\n"))
- (value (car results)))))
- (org-babel-result-cond (cdr (assoc :result-params params))
+ (pcase result-type
+ (`output (mapconcat #'identity (reverse (cdr results)) "\n"))
+ (`value (car results)))))
+ (org-babel-result-cond (cdr (assq :result-params params))
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))
- (cdr (assoc :rowname-names params))))))
-
-(defun org-babel-haskell-read-string (string)
- "Strip \\\"s from around a haskell string."
- (if (string-match "^\"\\([^\000]+\\)\"$" string)
- (match-string 1 string)
- string))
-
-(defun org-babel-haskell-initiate-session (&optional session params)
+ (org-babel-pick-name (cdr (assq :colname-names params))
+ (cdr (assq :colname-names params)))
+ (org-babel-pick-name (cdr (assq :rowname-names params))
+ (cdr (assq :rowname-names params))))))
+
+(defun org-babel-haskell-initiate-session (&optional _session _params)
"Initiate a haskell session.
If there is not a current inferior-process-buffer in SESSION
then create one. Return the initialized session."
@@ -131,7 +124,7 @@ then create one. Return the initialized session."
(format "let %s = %s"
(car pair)
(org-babel-haskell-var-to-haskell (cdr pair))))
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
(defun org-babel-haskell-var-to-haskell (var)
"Convert an elisp value VAR into a haskell variable.
@@ -144,13 +137,14 @@ specifying a variable of the same value."
(defvar org-export-copy-to-kill-ring)
(declare-function org-export-to-file "ox"
(backend file
- &optional async subtreep visible-only body-only ext-plist))
+ &optional async subtreep visible-only body-only
+ ext-plist post-process))
(defun org-babel-haskell-export-to-lhs (&optional arg)
"Export to a .lhs file with all haskell code blocks escaped.
When called with a prefix argument the resulting
.lhs file will be exported to a .tex file. This function will
create two new files, base-name.lhs and base-name.tex where
-base-name is the name of the current org-mode file.
+base-name is the name of the current Org file.
Note that all standard Babel literate programming
constructs (header arguments, no-web syntax etc...) are ignored."
@@ -178,12 +172,12 @@ constructs (header arguments, no-web syntax etc...) are ignored."
(save-match-data (setq indentation (length (match-string 1))))
(replace-match (save-match-data
(concat
- "#+begin_latex\n\\begin{code}\n"
+ "#+begin_export latex\n\\begin{code}\n"
(if (or preserve-indentp
(string-match "-i" (match-string 2)))
(match-string 3)
(org-remove-indentation (match-string 3)))
- "\n\\end{code}\n#+end_latex\n"))
+ "\n\\end{code}\n#+end_export\n"))
t t)
(indent-code-rigidly (match-beginning 0) (match-end 0) indentation)))
(save-excursion
diff --git a/lisp/ob-io.el b/lisp/ob-io.el
index ec2cd02..186b1b2 100644
--- a/lisp/ob-io.el
+++ b/lisp/ob-io.el
@@ -1,4 +1,4 @@
-;;; ob-io.el --- org-babel functions for Io evaluation
+;;; ob-io.el --- Babel Functions for Io -*- lexical-binding: t; -*-
;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
@@ -33,7 +33,6 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
(defvar org-babel-tangle-lang-exts) ;; Autoloaded
(add-to-list 'org-babel-tangle-lang-exts '("io" . "io"))
@@ -47,9 +46,8 @@ called by `org-babel-execute-src-block'"
(message "executing Io source code block")
(let* ((processed-params (org-babel-process-params params))
(session (org-babel-io-initiate-session (nth 0 processed-params)))
- (vars (nth 1 processed-params))
(result-params (nth 2 processed-params))
- (result-type (cdr (assoc :result-type params)))
+ (result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params))
(result (org-babel-io-evaluate
@@ -58,9 +56,9 @@ called by `org-babel-execute-src-block'"
(org-babel-reassemble-table
result
(org-babel-pick-name
- (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defvar org-babel-io-wrapper-method
"(
@@ -75,29 +73,29 @@ 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 Io"))
- (case result-type
- (output
+ (pcase result-type
+ (`output
(if (member "repl" result-params)
(org-babel-eval org-babel-io-command body)
(let ((src-file (org-babel-temp-file "io-")))
(progn (with-temp-file src-file (insert body))
(org-babel-eval
(concat org-babel-io-command " " src-file) "")))))
- (value (let* ((src-file (org-babel-temp-file "io-"))
- (wrapper (format org-babel-io-wrapper-method body)))
- (with-temp-file src-file (insert wrapper))
- (let ((raw (org-babel-eval
- (concat org-babel-io-command " " src-file) "")))
- (org-babel-result-cond result-params
- raw
- (org-babel-script-escape raw)))))))
+ (`value (let* ((src-file (org-babel-temp-file "io-"))
+ (wrapper (format org-babel-io-wrapper-method body)))
+ (with-temp-file src-file (insert wrapper))
+ (let ((raw (org-babel-eval
+ (concat org-babel-io-command " " src-file) "")))
+ (org-babel-result-cond result-params
+ raw
+ (org-babel-script-escape raw)))))))
-(defun org-babel-prep-session:io (session params)
+(defun org-babel-prep-session:io (_session _params)
"Prepare SESSION according to the header arguments specified in PARAMS."
(error "Sessions are not (yet) supported for Io"))
-(defun org-babel-io-initiate-session (&optional session)
+(defun org-babel-io-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 Io."
diff --git a/lisp/ob-java.el b/lisp/ob-java.el
index 5856c65..ccae020 100644
--- a/lisp/ob-java.el
+++ b/lisp/ob-java.el
@@ -1,4 +1,4 @@
-;;; ob-java.el --- org-babel functions for java evaluation
+;;; ob-java.el --- Babel Functions for Java -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
@@ -51,34 +51,32 @@ parameters may be used, like javac -verbose"
:type 'string)
(defun org-babel-execute:java (body params)
- (let* ((classname (or (cdr (assoc :classname params))
+ (let* ((classname (or (cdr (assq :classname params))
(error
"Can't compile a java block without a classname")))
(packagename (file-name-directory classname))
(src-file (concat classname ".java"))
- (cmpflag (or (cdr (assoc :cmpflag params)) ""))
- (cmdline (or (cdr (assoc :cmdline params)) ""))
- (full-body (org-babel-expand-body:generic body params))
- (compile
- (progn (with-temp-file src-file (insert full-body))
- (org-babel-eval
- (concat org-babel-java-compiler
- " " cmpflag " " src-file) ""))))
+ (cmpflag (or (cdr (assq :cmpflag params)) ""))
+ (cmdline (or (cdr (assq :cmdline params)) ""))
+ (full-body (org-babel-expand-body:generic body params)))
+ (with-temp-file src-file (insert full-body))
+ (org-babel-eval
+ (concat org-babel-java-compiler " " cmpflag " " src-file) "")
;; created package-name directories if missing
(unless (or (not packagename) (file-exists-p packagename))
(make-directory packagename 'parents))
(let ((results (org-babel-eval (concat org-babel-java-command
" " cmdline " " classname) "")))
(org-babel-reassemble-table
- (org-babel-result-cond (cdr (assoc :result-params params))
+ (org-babel-result-cond (cdr (assq :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)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
(provide 'ob-java)
diff --git a/lisp/ob-js.el b/lisp/ob-js.el
index 9440aa9..1a20d7e 100644
--- a/lisp/ob-js.el
+++ b/lisp/ob-js.el
@@ -1,4 +1,4 @@
-;;; ob-js.el --- org-babel functions for Javascript
+;;; ob-js.el --- Babel Functions for Javascript -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -39,7 +39,6 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
(declare-function run-mozilla "ext:moz" (arg))
@@ -62,14 +61,14 @@
(defun org-babel-execute:js (body params)
"Execute a block of Javascript code with org-babel.
This function is called by `org-babel-execute-src-block'"
- (let* ((org-babel-js-cmd (or (cdr (assoc :cmd params)) org-babel-js-cmd))
- (result-type (cdr (assoc :result-type params)))
+ (let* ((org-babel-js-cmd (or (cdr (assq :cmd params)) org-babel-js-cmd))
+ (result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:js params)))
- (result (if (not (string= (cdr (assoc :session params)) "none"))
+ (result (if (not (string= (cdr (assq :session params)) "none"))
;; session evaluation
(let ((session (org-babel-prep-session:js
- (cdr (assoc :session params)) params)))
+ (cdr (assq :session params)) params)))
(nth 1
(org-babel-comint-with-output
(session (format "%S" org-babel-js-eoe) t body)
@@ -89,7 +88,7 @@ This function is called by `org-babel-execute-src-block'"
(org-babel-eval
(format "%s %s" org-babel-js-cmd
(org-babel-process-file-name script-file)) "")))))
- (org-babel-result-cond (cdr (assoc :result-params params))
+ (org-babel-result-cond (cdr (assq :result-params params))
result (org-babel-js-read result))))
(defun org-babel-js-read (results)
@@ -97,7 +96,9 @@ 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 "^\\[[^\000]+\\]$" results))
+ (if (and (stringp results)
+ (string-prefix-p "[" results)
+ (string-suffix-p "]" results))
(org-babel-read
(concat "'"
(replace-regexp-in-string
@@ -134,7 +135,7 @@ specifying a variable of the same value."
(mapcar
(lambda (pair) (format "var %s=%s;"
(car pair) (org-babel-js-var-to-js (cdr pair))))
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
(defun org-babel-js-initiate-session (&optional session)
"If there is not a current inferior-process-buffer in SESSION
diff --git a/lisp/ob-keys.el b/lisp/ob-keys.el
index 6a63456..318f549 100644
--- a/lisp/ob-keys.el
+++ b/lisp/ob-keys.el
@@ -1,4 +1,4 @@
-;;; ob-keys.el --- key bindings for org-babel
+;;; ob-keys.el --- Key Bindings for Babel -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -23,8 +23,8 @@
;;; Commentary:
-;; Add org-babel keybindings to the org-mode keymap for exposing
-;; org-babel functions. These will all share a common prefix. See
+;; Add Org Babel keybindings to the Org mode keymap for exposing
+;; Org Babel functions. These will all share a common prefix. See
;; the value of `org-babel-key-bindings' for a list of interactive
;; functions and their associated keys.
diff --git a/lisp/ob-latex.el b/lisp/ob-latex.el
index 681e229..8fc0493 100644
--- a/lisp/ob-latex.el
+++ b/lisp/ob-latex.el
@@ -1,4 +1,4 @@
-;;; ob-latex.el --- org-babel functions for latex "evaluation"
+;;; ob-latex.el --- Babel Functions for LaTeX -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -32,11 +32,11 @@
;;; Code:
(require 'ob)
-(declare-function org-create-formula-image "org" (string tofile options buffer))
-(declare-function org-splice-latex-header "org"
- (tpl def-pkg pkg snippets-p &optional extra))
+(declare-function org-create-formula-image "org" (string tofile options buffer &optional type))
+(declare-function org-latex-compile "ox-latex" (texfile &optional snippet))
(declare-function org-latex-guess-inputenc "ox-latex" (header))
-(declare-function org-latex-compile "ox-latex" (file))
+(declare-function org-splice-latex-header "org" (tpl def-pkg pkg snippets-p &optional extra))
+(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("latex" . "tex"))
@@ -53,12 +53,16 @@
(defconst org-babel-header-args:latex
'((border . :any)
(fit . :any)
+ (imagemagick . ((nil t)))
(iminoptions . :any)
(imoutoptions . :any)
(packages . :any)
(pdfheight . :any)
(pdfpng . :any)
- (pdfwidth . :any))
+ (pdfwidth . :any)
+ (headers . :any)
+ (packages . :any)
+ (buffer . ((yes no))))
"LaTeX-specific header arguments.")
(defcustom org-babel-latex-htlatex "htlatex"
@@ -80,38 +84,38 @@
(regexp-quote (format "%S" (car pair)))
(if (stringp (cdr pair))
(cdr pair) (format "%S" (cdr pair)))
- body))) (mapcar #'cdr (org-babel-get-header params :var)))
- (org-babel-trim body))
+ body))) (org-babel--get-vars params))
+ (org-trim body))
(defun org-babel-execute:latex (body params)
"Execute a block of Latex code with Babel.
This function is called by `org-babel-execute-src-block'."
(setq body (org-babel-expand-body:latex body params))
- (if (cdr (assoc :file params))
- (let* ((out-file (cdr (assoc :file params)))
+ (if (cdr (assq :file params))
+ (let* ((out-file (cdr (assq :file params)))
+ (extension (file-name-extension out-file))
(tex-file (org-babel-temp-file "latex-" ".tex"))
- (border (cdr (assoc :border params)))
- (imagemagick (cdr (assoc :imagemagick params)))
- (im-in-options (cdr (assoc :iminoptions params)))
- (im-out-options (cdr (assoc :imoutoptions params)))
- (pdfpng (cdr (assoc :pdfpng params)))
- (fit (or (cdr (assoc :fit params)) border))
- (height (and fit (cdr (assoc :pdfheight params))))
- (width (and fit (cdr (assoc :pdfwidth params))))
- (headers (cdr (assoc :headers params)))
- (in-buffer (not (string= "no" (cdr (assoc :buffer params)))))
+ (border (cdr (assq :border params)))
+ (imagemagick (cdr (assq :imagemagick params)))
+ (im-in-options (cdr (assq :iminoptions params)))
+ (im-out-options (cdr (assq :imoutoptions params)))
+ (fit (or (cdr (assq :fit params)) border))
+ (height (and fit (cdr (assq :pdfheight params))))
+ (width (and fit (cdr (assq :pdfwidth params))))
+ (headers (cdr (assq :headers params)))
+ (in-buffer (not (string= "no" (cdr (assq :buffer params)))))
(org-latex-packages-alist
- (append (cdr (assoc :packages params)) org-latex-packages-alist)))
+ (append (cdr (assq :packages params)) org-latex-packages-alist)))
(cond
- ((and (string-match "\\.png$" out-file) (not imagemagick))
+ ((and (string-suffix-p ".png" out-file) (not imagemagick))
(org-create-formula-image
body out-file org-format-latex-options in-buffer))
- ((string-match "\\.tikz$" out-file)
+ ((string-suffix-p ".tikz" out-file)
(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))
+ ((and (or (string= "svg" extension)
+ (string= "html" extension))
(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
@@ -141,7 +145,7 @@ This function is called by `org-babel-execute-src-block'."
(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)
+ (if (string-suffix-p ".svg" out-file)
(progn
(shell-command "pwd")
(shell-command (format "mv %s %s"
@@ -149,13 +153,13 @@ This function is called by `org-babel-execute-src-block'."
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)
+ (if (string-suffix-p ".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)
+ ((or (string= "pdf" extension) imagemagick)
(with-temp-file tex-file
(require 'ox-latex)
(insert
@@ -188,16 +192,16 @@ This function is called by `org-babel-execute-src-block'."
(when (file-exists-p out-file) (delete-file out-file))
(let ((transient-pdf-file (org-babel-latex-tex-to-pdf tex-file)))
(cond
- ((string-match "\\.pdf$" out-file)
+ ((string= "pdf" extension)
(rename-file transient-pdf-file out-file))
(imagemagick
(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))))))
- ((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))))
+ (delete-file transient-pdf-file)))
+ (t
+ (error "Can not create %s files, please specify a .png or .pdf file or try the :imagemagick header argument"
+ extension))))))
nil) ;; signal that output has already been written to file
body))
@@ -213,7 +217,7 @@ This function is called by `org-babel-execute-src-block'."
(require 'ox-latex)
(org-latex-compile file))
-(defun org-babel-prep-session:latex (session params)
+(defun org-babel-prep-session:latex (_session _params)
"Return an error because LaTeX doesn't support sessions."
(error "LaTeX does not support sessions"))
diff --git a/lisp/ob-ledger.el b/lisp/ob-ledger.el
index d07f257..ee2ce0a 100644
--- a/lisp/ob-ledger.el
+++ b/lisp/ob-ledger.el
@@ -1,4 +1,4 @@
-;;; ob-ledger.el --- org-babel functions for ledger evaluation
+;;; ob-ledger.el --- Babel Functions for Ledger -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -46,8 +46,7 @@
"Execute a block of Ledger entries with org-babel. This function is
called by `org-babel-execute-src-block'."
(message "executing Ledger source code block")
- (let ((result-params (split-string (or (cdr (assoc :results params)) "")))
- (cmdline (cdr (assoc :cmdline params)))
+ (let ((cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "ledger-"))
(out-file (org-babel-temp-file "ledger-output-")))
(with-temp-file in-file (insert body))
@@ -61,7 +60,7 @@ called by `org-babel-execute-src-block'."
" > " (org-babel-process-file-name out-file))))
(with-temp-buffer (insert-file-contents out-file) (buffer-string))))
-(defun org-babel-prep-session:ledger (session params)
+(defun org-babel-prep-session:ledger (_session _params)
(error "Ledger does not support sessions"))
(provide 'ob-ledger)
diff --git a/lisp/ob-lilypond.el b/lisp/ob-lilypond.el
index bfbace5..3d2e50f 100644
--- a/lisp/ob-lilypond.el
+++ b/lisp/ob-lilypond.el
@@ -1,4 +1,4 @@
-;;; ob-lilypond.el --- org-babel functions for lilypond evaluation
+;;; ob-lilypond.el --- Babel Functions for Lilypond -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -92,7 +92,7 @@ you can leave the string empty on this case."
:version "24.3"
:package-version '(Org . "8.2.7")
:set
- (lambda (symbol value)
+ (lambda (_symbol value)
(setq
org-babel-lilypond-ly-command (nth 0 value)
org-babel-lilypond-pdf-command (nth 1 value)
@@ -123,7 +123,7 @@ blocks.")
(defun org-babel-expand-body:lilypond (body params)
"Expand BODY according to PARAMS, return the expanded body."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
@@ -157,9 +157,8 @@ specific arguments to =org-babel-tangle="
(defun org-babel-lilypond-process-basic (body params)
"Execute a lilypond block in basic mode."
- (let* ((result-params (cdr (assoc :result-params params)))
- (out-file (cdr (assoc :file params)))
- (cmdline (or (cdr (assoc :cmdline params))
+ (let* ((out-file (cdr (assq :file params)))
+ (cmdline (or (cdr (assq :cmdline params))
""))
(in-file (org-babel-temp-file "lilypond-")))
@@ -182,7 +181,7 @@ specific arguments to =org-babel-tangle="
cmdline
in-file) "")) nil)
-(defun org-babel-prep-session:lilypond (session params)
+(defun org-babel-prep-session:lilypond (_session _params)
"Return an error because LilyPond exporter does not support sessions."
(error "Sorry, LilyPond does not currently support sessions!"))
@@ -272,25 +271,19 @@ LINE is the erroneous line"
(defun org-babel-lilypond-parse-line-num (&optional buffer)
"Extract error line number."
- (when buffer
- (set-buffer buffer))
+ (when buffer (set-buffer buffer))
(let ((start
(and (search-backward ":" nil t)
(search-backward ":" nil t)
(search-backward ":" nil t)
- (search-backward ":" nil t)))
- (num nil))
- (if start
- (progn
- (forward-char)
- (let ((num (buffer-substring
- (+ 1 start)
- (- (search-forward ":" nil t) 1))))
- (setq num (string-to-number num))
- (if (numberp num)
- num
- nil)))
- nil)))
+ (search-backward ":" nil t))))
+ (when start
+ (forward-char)
+ (let ((num (string-to-number
+ (buffer-substring
+ (+ 1 start)
+ (- (search-forward ":" nil t) 1)))))
+ (and (numberp num) num)))))
(defun org-babel-lilypond-parse-error-line (file-name lineNo)
"Extract the erroneous line from the tangled .ly file
diff --git a/lisp/ob-lisp.el b/lisp/ob-lisp.el
index 04df7fb..da7e4f4 100644
--- a/lisp/ob-lisp.el
+++ b/lisp/ob-lisp.el
@@ -1,4 +1,4 @@
-;;; ob-lisp.el --- org-babel functions for common lisp evaluation
+;;; ob-lisp.el --- Babel Functions for Common Lisp -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -25,17 +25,22 @@
;;; Commentary:
-;;; support for evaluating common lisp code, relies on slime for all eval
+;;; Support for evaluating Common Lisp code, relies on SLY or SLIME
+;;; for all eval.
;;; Requirements:
-;; Requires SLIME (Superior Lisp Interaction Mode for Emacs.)
-;; See http://common-lisp.net/project/slime/
+;; Requires SLY (Sylvester the Cat's Common Lisp IDE) or SLIME
+;; (Superior Lisp Interaction Mode for Emacs). See:
+;; - https://github.com/capitaomorte/sly
+;; - http://common-lisp.net/project/slime/
;;; Code:
(require 'ob)
+(declare-function sly-eval "ext:sly" (sexp &optional package))
(declare-function slime-eval "ext:slime" (sexp &optional package))
+(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("lisp" . "lisp"))
@@ -43,6 +48,14 @@
(defvar org-babel-default-header-args:lisp '())
(defvar org-babel-header-args:lisp '((package . :any)))
+(defcustom org-babel-lisp-eval-fn #'slime-eval
+ "The function to be called to evaluate code on the Lisp side.
+Valid values include `slime-eval' and `sly-eval'."
+ :group 'org-babel
+ :version "25.2"
+ :package-version '(Org . "9.0")
+ :type 'function)
+
(defcustom org-babel-lisp-dir-fmt
"(let ((*default-pathname-defaults* #P%S\n)) %%s\n)"
"Format string used to wrap code bodies to set the current directory.
@@ -54,51 +67,54 @@ current directory string."
(defun org-babel-expand-body:lisp (body params)
"Expand BODY according to PARAMS, return the expanded body."
- (let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
- (result-params (cdr (assoc :result-params params)))
+ (let* ((vars (org-babel--get-vars params))
+ (result-params (cdr (assq :result-params params)))
(print-level nil) (print-length nil)
- (body (org-babel-trim
- (if (> (length vars) 0)
- (concat "(let ("
- (mapconcat
- (lambda (var)
- (format "(%S (quote %S))" (car var) (cdr var)))
- vars "\n ")
- ")\n" body ")")
- body))))
+ (body (if (null vars) (org-trim body)
+ (concat "(let ("
+ (mapconcat
+ (lambda (var)
+ (format "(%S (quote %S))" (car var) (cdr var)))
+ vars "\n ")
+ ")\n" body ")"))))
(if (or (member "code" result-params)
(member "pp" result-params))
(format "(pprint %s)" body)
body)))
(defun org-babel-execute:lisp (body params)
- "Execute a block of Common Lisp code with Babel."
- (require 'slime)
+ "Execute a block of Common Lisp code with Babel.
+BODY is the contents of the block, as a string. PARAMS is
+a property list containing the parameters of the block."
+ (require (pcase org-babel-lisp-eval-fn
+ (`slime-eval 'slime)
+ (`sly-eval 'sly)))
(org-babel-reassemble-table
(let ((result
- (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))
+ (funcall (if (member "output" (cdr (assq :result-params params)))
+ #'car #'cadr)
+ (with-temp-buffer
+ (insert (org-babel-expand-body:lisp body params))
+ (funcall org-babel-lisp-eval-fn
+ `(swank:eval-and-grab-output
+ ,(let ((dir (if (assq :dir params)
+ (cdr (assq :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 (assq :package params)))))))
+ (org-babel-result-cond (cdr (assq :result-params params))
result
(condition-case nil
(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))
- (cdr (assoc :rownames params)))))
+ (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)))))
(defun org-babel-lisp-vector-to-list (results)
;; TODO: better would be to replace #(...) with [...]
diff --git a/lisp/ob-lob.el b/lisp/ob-lob.el
index cf5cb4e..1c4123b 100644
--- a/lisp/ob-lob.el
+++ b/lisp/ob-lob.el
@@ -1,4 +1,4 @@
-;;; ob-lob.el --- functions supporting the Library of Babel
+;;; ob-lob.el --- Functions Supporting the Library of Babel -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -23,27 +23,27 @@
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Code:
-(eval-when-compile
- (require 'cl))
+(require 'cl-lib)
(require 'ob-core)
(require 'ob-table)
-(declare-function org-babel-in-example-or-verbatim "ob-exp" nil)
+(declare-function org-babel-ref-split-args "ob-ref" (arg-string))
+(declare-function org-element-at-point "org-element" ())
+(declare-function org-element-context "org-element" (&optional element))
+(declare-function org-element-property "org-element" (property element))
+(declare-function org-element-type "org-element" (element))
(defvar org-babel-library-of-babel nil
"Library of source-code blocks.
-This is an association list. Populate the library by adding
-files to `org-babel-lob-files'.")
-
-(defcustom org-babel-lob-files nil
- "Files used to populate the `org-babel-library-of-babel'.
-To add files to this list use the `org-babel-lob-ingest' command."
- :group 'org-babel
- :version "24.1"
- :type '(repeat file))
+This is an association list. Populate the library by calling
+`org-babel-lob-ingest' on files containing source blocks.")
(defvar org-babel-default-lob-header-args '((:exports . "results"))
- "Default header arguments to use when exporting #+lob/call lines.")
+ "Default header arguments to use when exporting Babel calls.
+By default, a Babel call inherits its arguments from the source
+block being called. Header arguments defined in this variable
+take precedence over these. It is useful for properties that
+should not be inherited from a source block.")
(defun org-babel-lob-ingest (&optional file)
"Add all named source blocks defined in FILE to `org-babel-library-of-babel'."
@@ -62,24 +62,7 @@ To add files to this list use the `org-babel-lob-ingest' command."
lob-ingest-count (if (> lob-ingest-count 1) "s" ""))
lob-ingest-count))
-(defconst org-babel-block-lob-one-liner-regexp
- (concat
- "^\\([ \t]*?\\)#\\+call:[ \t]+\\([^()\n]+?\\)\\(\\[\\(.*\\)\\]\\|\\(\\)\\)"
- "(\\([^\n]*?\\))\\(\\[.+\\]\\|\\)[ \t]*\\(\\([^\n]*\\)\\)?")
- "Regexp to match non-inline calls to predefined source block functions.")
-
-(defconst org-babel-inline-lob-one-liner-regexp
- (concat
- "\\([^\n]*?\\)call_\\([^()[:space:]\n]+?\\)\\(\\[\\(.*?\\)\\]\\|\\(\\)\\)"
- "(\\(.*?\\))\\(\\[\\(.*?\\)\\]\\)?")
- "Regexp to match inline calls to predefined source block functions.")
-
-(defconst org-babel-lob-one-liner-regexp
- (concat "\\(" org-babel-block-lob-one-liner-regexp
- "\\|" org-babel-inline-lob-one-liner-regexp "\\)")
- "Regexp to match calls to predefined source block functions.")
-
-;; functions for executing lob one-liners
+;; Functions for executing lob one-liners.
;;;###autoload
(defun org-babel-lob-execute-maybe ()
@@ -88,87 +71,76 @@ Detect if this is context for a Library Of Babel source block and
if so then run the appropriate source block from the Library."
(interactive)
(let ((info (org-babel-lob-get-info)))
- (if (and (nth 0 info) (not (org-babel-in-example-or-verbatim)))
- (progn (org-babel-lob-execute info) t)
- nil)))
+ (when info
+ (org-babel-execute-src-block nil info)
+ t)))
+
+(defun org-babel-lob--src-info (name)
+ "Return internal representation for Babel data named NAME.
+NAME is a string. This function looks into the current document
+for a Babel call or source block. If none is found, it looks
+after NAME in the Library of Babel. Eventually, if that also
+fails, it returns nil."
+ ;; During export, look into the pristine copy of the document being
+ ;; exported instead of the current one, which could miss some data.
+ (with-current-buffer (or org-babel-exp-reference-buffer (current-buffer))
+ (org-with-wide-buffer
+ (goto-char (point-min))
+ (catch :found
+ (let ((case-fold-search t)
+ (regexp (org-babel-named-data-regexp-for-name name)))
+ (while (re-search-forward regexp nil t)
+ (let ((element (org-element-at-point)))
+ (when (equal name (org-element-property :name element))
+ (throw :found
+ (pcase (org-element-type element)
+ (`src-block (org-babel-get-src-block-info t element))
+ (`babel-call (org-babel-lob-get-info element))
+ ;; Non-executable data found. Since names are
+ ;; supposed to be unique throughout a document,
+ ;; bail out.
+ (_ nil))))))
+ ;; No element named NAME in buffer. Try Library of Babel.
+ (cdr (assoc-string name org-babel-library-of-babel)))))))
;;;###autoload
-(defun org-babel-lob-get-info ()
- "Return a Library of Babel function call as a string."
- (let ((case-fold-search t)
- (nonempty (lambda (a b)
- (let ((it (match-string a)))
- (if (= (length it) 0) (match-string b) it)))))
- (save-excursion
- (beginning-of-line 1)
- (when (looking-at org-babel-lob-one-liner-regexp)
- (append
- (mapcar #'org-no-properties
- (list
- (format "%s%s(%s)%s"
- (funcall nonempty 3 12)
- (if (not (= 0 (length (funcall nonempty 5 14))))
- (concat "[" (funcall nonempty 5 14) "]") "")
- (or (funcall nonempty 7 16) "")
- (or (funcall nonempty 8 19) ""))
- (funcall nonempty 9 18)))
- (list (length (if (= (length (match-string 12)) 0)
- (match-string 2) (match-string 11)))
- (save-excursion
- (forward-line -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)
- "Execute the lob call specified by INFO."
- (let* ((mkinfo (lambda (p)
- (list "emacs-lisp" "results" p nil
- (nth 3 info) ;; name
- (nth 2 info))))
- (pre-params (apply #'org-babel-merge-params
- org-babel-default-header-args
- org-babel-default-header-args:emacs-lisp
- (append
- (org-babel-params-from-properties)
- (list
- (org-babel-parse-header-arguments
- (org-no-properties
- (concat
- ":var results="
- (mapconcat #'identity (butlast info 2)
- " "))))))))
- (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
- ;; 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
- 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 pre-info))))))
+(defun org-babel-lob-get-info (&optional datum)
+ "Return internal representation for Library of Babel function call.
+Consider DATUM, when provided, or element at point. Return nil
+when not on an appropriate location. Otherwise return a list
+compatible with `org-babel-get-src-block-info', which see."
+ (let* ((context (or datum (org-element-context)))
+ (type (org-element-type context)))
+ (when (memq type '(babel-call inline-babel-call))
+ (pcase (org-babel-lob--src-info (org-element-property :call context))
+ (`(,language ,body ,header ,_ ,_ ,_ ,coderef)
+ (let ((begin (org-element-property (if (eq type 'inline-babel-call)
+ :begin
+ :post-affiliated)
+ context)))
+ (list language
+ body
+ (apply #'org-babel-merge-params
+ header
+ org-babel-default-lob-header-args
+ (append
+ (org-with-wide-buffer
+ (goto-char begin)
+ (org-babel-params-from-properties language))
+ (list
+ (org-babel-parse-header-arguments
+ (org-element-property :inside-header context))
+ (let ((args (org-element-property :arguments context)))
+ (and args
+ (mapcar (lambda (ref) (cons :var ref))
+ (org-babel-ref-split-args args))))
+ (org-babel-parse-header-arguments
+ (org-element-property :end-header context)))))
+ nil
+ (org-element-property :name context)
+ begin
+ coderef)))
+ (_ nil)))))
(provide 'ob-lob)
diff --git a/lisp/ob-lua.el b/lisp/ob-lua.el
new file mode 100644
index 0000000..afb5c45
--- /dev/null
+++ b/lisp/ob-lua.el
@@ -0,0 +1,403 @@
+;;; ob-lua.el --- Org Babel functions for Lua evaluation -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2014, 2016 Free Software Foundation, Inc.
+
+;; Authors: Dieter Schoen
+;; 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/>.
+
+;; Requirements:
+;; for session support, lua-mode is needed.
+;; lua-mode is not part of GNU Emacs/orgmode, but can be obtained
+;; from marmalade or melpa.
+;; The source respository is here:
+;; https://github.com/immerrr/lua-mode
+
+;; However, sessions are not yet working.
+
+;; Org-Babel support for evaluating lua source code.
+
+;;; Code:
+(require 'ob)
+(require 'cl-lib)
+
+(declare-function org-remove-indentation "org" (code &optional n))
+(declare-function org-trim "org" (s &optional keep-lead))
+(declare-function lua-shell "ext:lua-mode" (&optional argprompt))
+(declare-function lua-toggle-shells "ext:lua-mode" (arg))
+(declare-function run-lua "ext:lua" (cmd &optional dedicated show))
+
+(defvar org-babel-tangle-lang-exts)
+(add-to-list 'org-babel-tangle-lang-exts '("lua" . "lua"))
+
+(defvar org-babel-default-header-args:lua '())
+
+(defcustom org-babel-lua-command "lua"
+ "Name of the command for executing Lua code."
+ :version "24.5"
+ :package-version '(Org . "8.3")
+ :group 'org-babel
+ :type 'string)
+
+(defcustom org-babel-lua-mode 'lua-mode
+ "Preferred lua mode for use in running lua interactively.
+This will typically be 'lua-mode."
+ :group 'org-babel
+ :version "24.5"
+ :package-version '(Org . "8.3")
+ :type 'symbol)
+
+(defcustom org-babel-lua-hline-to "None"
+ "Replace hlines in incoming tables with this when translating to lua."
+ :group 'org-babel
+ :version "24.5"
+ :package-version '(Org . "8.3")
+ :type 'string)
+
+(defcustom org-babel-lua-None-to 'hline
+ "Replace 'None' in lua tables with this before returning."
+ :group 'org-babel
+ :version "24.5"
+ :package-version '(Org . "8.3")
+ :type 'symbol)
+
+(defun org-babel-execute:lua (body params)
+ "Execute a block of Lua code with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((session (org-babel-lua-initiate-session
+ (cdr (assq :session params))))
+ (result-params (cdr (assq :result-params params)))
+ (result-type (cdr (assq :result-type params)))
+ (return-val (when (and (eq result-type 'value) (not session))
+ (cdr (assq :return params))))
+ (preamble (cdr (assq :preamble params)))
+ (full-body
+ (org-babel-expand-body:generic
+ (concat body (if return-val (format "\nreturn %s" return-val) ""))
+ params (org-babel-variable-assignments:lua params)))
+ (result (org-babel-lua-evaluate
+ session full-body result-type result-params preamble)))
+ (org-babel-reassemble-table
+ result
+ (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))))))
+
+(defun org-babel-prep-session:lua (session params)
+ "Prepare SESSION according to the header arguments in PARAMS.
+VARS contains resolved variable references"
+ (let* ((session (org-babel-lua-initiate-session session))
+ (var-lines
+ (org-babel-variable-assignments:lua params)))
+ (org-babel-comint-in-buffer session
+ (mapc (lambda (var)
+ (end-of-line 1) (insert var) (comint-send-input)
+ (org-babel-comint-wait-for-output session)) var-lines))
+ session))
+
+(defun org-babel-load-session:lua (session body params)
+ "Load BODY into SESSION."
+ (save-window-excursion
+ (let ((buffer (org-babel-prep-session:lua 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:lua (params)
+ "Return a list of Lua statements assigning the block's variables."
+ (mapcar
+ (lambda (pair)
+ (format "%s=%s"
+ (car pair)
+ (org-babel-lua-var-to-lua (cdr pair))))
+ (org-babel--get-vars params)))
+
+(defun org-babel-lua-var-to-lua (var)
+ "Convert an elisp value to a lua variable.
+Convert an elisp value, VAR, into a string of lua source code
+specifying a variable of the same value."
+ (if (listp var)
+ (if (and (= 1 (length var)) (not (listp (car var))))
+ (org-babel-lua-var-to-lua (car var))
+ (if (and
+ (= 2 (length var))
+ (not (listp (car var))))
+ (concat
+ (substring-no-properties (car var))
+ "="
+ (org-babel-lua-var-to-lua (cdr var)))
+ (concat "{" (mapconcat #'org-babel-lua-var-to-lua var ", ") "}")))
+ (if (eq var 'hline)
+ org-babel-lua-hline-to
+ (format
+ (if (and (stringp var) (string-match "[\n\r]" var)) "\"\"%S\"\"" "%S")
+ (if (stringp var) (substring-no-properties var) var)))))
+
+(defun org-babel-lua-table-or-string (results)
+ "Convert RESULTS into an appropriate elisp value.
+If the results look like a list or tuple, then convert them into an
+Emacs-lisp table, otherwise return the results as a string."
+ (let ((res (org-babel-script-escape results)))
+ (if (listp res)
+ (mapcar (lambda (el) (if (eq el 'None)
+ org-babel-lua-None-to el))
+ res)
+ res)))
+
+(defvar org-babel-lua-buffers '((:default . "*Lua*")))
+
+(defun org-babel-lua-session-buffer (session)
+ "Return the buffer associated with SESSION."
+ (cdr (assoc session org-babel-lua-buffers)))
+
+(defun org-babel-lua-with-earmuffs (session)
+ (let ((name (if (stringp session) session (format "%s" session))))
+ (if (and (string= "*" (substring name 0 1))
+ (string= "*" (substring name (- (length name) 1))))
+ name
+ (format "*%s*" name))))
+
+(defun org-babel-lua-without-earmuffs (session)
+ (let ((name (if (stringp session) session (format "%s" session))))
+ (if (and (string= "*" (substring name 0 1))
+ (string= "*" (substring name (- (length name) 1))))
+ (substring name 1 (- (length name) 1))
+ name)))
+
+(defvar lua-default-interpreter)
+(defvar lua-which-bufname)
+(defvar lua-shell-buffer-name)
+(defun org-babel-lua-initiate-session-by-key (&optional session)
+ "Initiate a lua session.
+If there is not a current inferior-process-buffer in SESSION
+then create. Return the initialized session."
+ ;; (require org-babel-lua-mode)
+ (save-window-excursion
+ (let* ((session (if session (intern session) :default))
+ (lua-buffer (org-babel-lua-session-buffer session))
+ ;; (cmd (if (member system-type '(cygwin windows-nt ms-dos))
+ ;; (concat org-babel-lua-command " -i")
+ ;; org-babel-lua-command))
+ )
+ (cond
+ ((and (eq 'lua-mode org-babel-lua-mode)
+ (fboundp 'lua-start-process)) ; lua-mode.el
+ ;; Make sure that lua-which-bufname is initialized, as otherwise
+ ;; it will be overwritten the first time a Lua buffer is
+ ;; created.
+ ;;(lua-toggle-shells lua-default-interpreter)
+ ;; `lua-shell' creates a buffer whose name is the value of
+ ;; `lua-which-bufname' with '*'s at the beginning and end
+ (let* ((bufname (if (and lua-buffer (buffer-live-p lua-buffer))
+ (replace-regexp-in-string ;; zap surrounding *
+ "^\\*\\([^*]+\\)\\*$" "\\1" (buffer-name lua-buffer))
+ (concat "Lua-" (symbol-name session))))
+ (lua-which-bufname bufname))
+ (lua-start-process)
+ (setq lua-buffer (org-babel-lua-with-earmuffs bufname))))
+ (t
+ (error "No function available for running an inferior Lua")))
+ (setq org-babel-lua-buffers
+ (cons (cons session lua-buffer)
+ (assq-delete-all session org-babel-lua-buffers)))
+ session)))
+
+(defun org-babel-lua-initiate-session (&optional session _params)
+ "Create a session named SESSION according to PARAMS."
+ (unless (string= session "none")
+ (error "Sessions currently not supported, work in progress")
+ (org-babel-lua-session-buffer
+ (org-babel-lua-initiate-session-by-key session))))
+
+(defvar org-babel-lua-eoe-indicator "--eoe"
+ "A string to indicate that evaluation has completed.")
+
+(defvar org-babel-lua-wrapper-method
+ "
+function main()
+%s
+end
+
+fd=io.open(\"%s\", \"w\")
+fd:write( main() )
+fd:close()")
+(defvar org-babel-lua-pp-wrapper-method
+ "
+-- table to string
+function t2s(t, indent)
+ if indent == nil then
+ indent = \"\"
+ end
+ if type(t) == \"table\" then
+ ts = \"\"
+ for k,v in pairs(t) do
+ if type(v) == \"table\" then
+ ts = ts .. indent .. t2s(k,indent .. \" \") .. \" = \\n\" ..
+ t2s(v, indent .. \" \")
+ else
+ ts = ts .. indent .. t2s(k,indent .. \" \") .. \" = \" ..
+ t2s(v, indent .. \" \") .. \"\\n\"
+ end
+ end
+ return ts
+ else
+ return tostring(t)
+ end
+end
+
+
+function main()
+%s
+end
+
+fd=io.open(\"%s\", \"w\")
+fd:write(t2s(main()))
+fd:close()")
+
+(defun org-babel-lua-evaluate
+ (session body &optional result-type result-params preamble)
+ "Evaluate BODY as Lua code."
+ (if session
+ (org-babel-lua-evaluate-session
+ session body result-type result-params)
+ (org-babel-lua-evaluate-external-process
+ body result-type result-params preamble)))
+
+(defun org-babel-lua-evaluate-external-process
+ (body &optional result-type result-params preamble)
+ "Evaluate BODY in external lua 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."
+ (let ((raw
+ (pcase result-type
+ (`output (org-babel-eval org-babel-lua-command
+ (concat (if preamble (concat preamble "\n"))
+ body)))
+ (`value (let ((tmp-file (org-babel-temp-file "lua-")))
+ (org-babel-eval
+ org-babel-lua-command
+ (concat
+ (if preamble (concat preamble "\n") "")
+ (format
+ (if (member "pp" result-params)
+ org-babel-lua-pp-wrapper-method
+ org-babel-lua-wrapper-method)
+ (mapconcat
+ (lambda (line) (format "\t%s" line))
+ (split-string
+ (org-remove-indentation
+ (org-trim body))
+ "[\r\n]") "\n")
+ (org-babel-process-file-name tmp-file 'noquote))))
+ (org-babel-eval-read-file tmp-file))))))
+ (org-babel-result-cond result-params
+ raw
+ (org-babel-lua-table-or-string (org-trim raw)))))
+
+(defun org-babel-lua-evaluate-session
+ (session body &optional result-type result-params)
+ "Pass BODY to the Lua process in SESSION.
+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."
+ (let* ((send-wait (lambda () (comint-send-input nil t) (sleep-for 0 5)))
+ (dump-last-value
+ (lambda
+ (tmp-file pp)
+ (mapc
+ (lambda (statement) (insert statement) (funcall send-wait))
+ (if pp
+ (list
+ "-- table to string
+function t2s(t, indent)
+ if indent == nil then
+ indent = \"\"
+ end
+ if type(t) == \"table\" then
+ ts = \"\"
+ for k,v in pairs(t) do
+ if type(v) == \"table\" then
+ ts = ts .. indent .. t2s(k,indent .. \" \") .. \" = \\n\" ..
+ t2s(v, indent .. \" \")
+ else
+ ts = ts .. indent .. t2s(k,indent .. \" \") .. \" = \" ..
+ t2s(v, indent .. \" \") .. \"\\n\"
+ end
+ end
+ return ts
+ else
+ return tostring(t)
+ end
+end
+"
+ (concat "fd:write(_))
+fd:close()"
+ (org-babel-process-file-name tmp-file 'noquote)))
+ (list (format "fd=io.open(\"%s\", \"w\")
+fd:write( _ )
+fd:close()"
+ (org-babel-process-file-name tmp-file
+ 'noquote)))))))
+ (input-body (lambda (body)
+ (mapc (lambda (line) (insert line) (funcall send-wait))
+ (split-string body "[\r\n]"))
+ (funcall send-wait)))
+ (results
+ (pcase result-type
+ (`output
+ (mapconcat
+ #'org-trim
+ (butlast
+ (org-babel-comint-with-output
+ (session org-babel-lua-eoe-indicator t body)
+ (funcall input-body body)
+ (funcall send-wait) (funcall send-wait)
+ (insert org-babel-lua-eoe-indicator)
+ (funcall send-wait))
+ 2) "\n"))
+ (`value
+ (let ((tmp-file (org-babel-temp-file "lua-")))
+ (org-babel-comint-with-output
+ (session org-babel-lua-eoe-indicator nil body)
+ (let ((comint-process-echoes nil))
+ (funcall input-body body)
+ (funcall dump-last-value tmp-file
+ (member "pp" result-params))
+ (funcall send-wait) (funcall send-wait)
+ (insert org-babel-lua-eoe-indicator)
+ (funcall send-wait)))
+ (org-babel-eval-read-file tmp-file))))))
+ (unless (string= (substring org-babel-lua-eoe-indicator 1 -1) results)
+ (org-babel-result-cond result-params
+ results
+ (org-babel-lua-table-or-string results)))))
+
+(defun org-babel-lua-read-string (string)
+ "Strip 's from around Lua string."
+ (org-unbracket-string "'" "'" string))
+
+(provide 'ob-lua)
+
+
+
+;;; ob-lua.el ends here
diff --git a/lisp/ob-makefile.el b/lisp/ob-makefile.el
index 8f33773..69c6e51 100644
--- a/lisp/ob-makefile.el
+++ b/lisp/ob-makefile.el
@@ -1,4 +1,4 @@
-;;; ob-makefile.el --- org-babel functions for makefile evaluation
+;;; ob-makefile.el --- Babel Functions for Makefile -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -24,19 +24,19 @@
;;; Commentary:
-;; This file exists solely for tangling a Makefile from org-mode files.
+;; This file exists solely for tangling a Makefile from Org files.
;;; Code:
(require 'ob)
(defvar org-babel-default-header-args:makefile '())
-(defun org-babel-execute:makefile (body params)
+(defun org-babel-execute:makefile (body _params)
"Execute a block of makefile code.
This function is called by `org-babel-execute-src-block'."
body)
-(defun org-babel-prep-session:makefile (session params)
+(defun org-babel-prep-session:makefile (_session _params)
"Return an error if the :session header argument is set. Make
does not support sessions."
(error "Makefile sessions are nonsensical"))
diff --git a/lisp/ob-matlab.el b/lisp/ob-matlab.el
index 69b4c45..0d3909d 100644
--- a/lisp/ob-matlab.el
+++ b/lisp/ob-matlab.el
@@ -1,4 +1,4 @@
-;;; ob-matlab.el --- org-babel support for matlab evaluation
+;;; ob-matlab.el --- Babel support for Matlab -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
diff --git a/lisp/ob-maxima.el b/lisp/ob-maxima.el
index 9b6cee6..4d16156 100644
--- a/lisp/ob-maxima.el
+++ b/lisp/ob-maxima.el
@@ -1,4 +1,4 @@
-;;; ob-maxima.el --- org-babel functions for maxima evaluation
+;;; ob-maxima.el --- Babel Functions for Maxima -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -48,7 +48,7 @@
(defun org-babel-maxima-expand (body params)
"Expand a block of Maxima code according to its header arguments."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(mapconcat 'identity
(list
;; graphic output
@@ -69,9 +69,9 @@
"Execute a block of Maxima entries with org-babel.
This function is called by `org-babel-execute-src-block'."
(message "executing Maxima source code block")
- (let ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (let ((result-params (split-string (or (cdr (assq :results params)) "")))
(result
- (let* ((cmdline (or (cdr (assoc :cmdline params)) ""))
+ (let* ((cmdline (or (cdr (assq :cmdline params)) ""))
(in-file (org-babel-temp-file "maxima-" ".max"))
(cmd (format "%s --very-quiet -r 'batchload(%S)$' %s"
org-babel-maxima-command in-file cmdline)))
@@ -98,7 +98,7 @@ This function is called by `org-babel-execute-src-block'."
(org-babel-import-elisp-from-file tmp-file))))))
-(defun org-babel-prep-session:maxima (session params)
+(defun org-babel-prep-session:maxima (_session _params)
(error "Maxima does not support sessions"))
(defun org-babel-maxima-var-to-maxima (pair)
diff --git a/lisp/ob-mscgen.el b/lisp/ob-mscgen.el
index dae4c65..f53b09f 100644
--- a/lisp/ob-mscgen.el
+++ b/lisp/ob-mscgen.el
@@ -1,4 +1,4 @@
-;;; ob-msc.el --- org-babel functions for mscgen evaluation
+;;; ob-msc.el --- Babel Functions for Mscgen -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -65,15 +65,15 @@
This function is called by `org-babel-execute-src-block'.
Default filetype is png. Modify by setting :filetype parameter to
mscgen supported formats."
- (let* ((out-file (or (cdr (assoc :file params)) "output.png" ))
- (filetype (or (cdr (assoc :filetype params)) "png" )))
- (unless (cdr (assoc :file params))
+ (let* ((out-file (or (cdr (assq :file params)) "output.png" ))
+ (filetype (or (cdr (assq :filetype params)) "png" )))
+ (unless (cdr (assq :file params))
(error "
ERROR: no output file specified. Add \":file name.png\" to the src header"))
(org-babel-eval (concat "mscgen -T " filetype " -o " out-file) body)
nil)) ;; signal that output has already been written to file
-(defun org-babel-prep-session:mscgen (session params)
+(defun org-babel-prep-session:mscgen (_session _params)
"Raise an error because Mscgen doesn't support sessions."
(error "Mscgen does not support sessions"))
diff --git a/lisp/ob-ocaml.el b/lisp/ob-ocaml.el
index eadc388..4c9d295 100644
--- a/lisp/ob-ocaml.el
+++ b/lisp/ob-ocaml.el
@@ -1,4 +1,4 @@
-;;; ob-ocaml.el --- org-babel functions for ocaml evaluation
+;;; ob-ocaml.el --- Babel Functions for Ocaml -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -37,11 +37,11 @@
;;; Code:
(require 'ob)
(require 'comint)
-(eval-when-compile (require 'cl))
(declare-function tuareg-run-caml "ext:tuareg" ())
(declare-function tuareg-run-ocaml "ext:tuareg" ())
(declare-function tuareg-interactive-send-input "ext:tuareg" ())
+(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("ocaml" . "ml"))
@@ -60,14 +60,13 @@
(defun org-babel-execute:ocaml (body params)
"Execute a block of Ocaml code with Babel."
- (let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
- (full-body (org-babel-expand-body:generic
+ (let* ((full-body (org-babel-expand-body:generic
body params
(org-babel-variable-assignments:ocaml params)))
(session (org-babel-prep-session:ocaml
- (cdr (assoc :session params)) params))
+ (cdr (assq :session params)) params))
(raw (org-babel-comint-with-output
- (session org-babel-ocaml-eoe-output t full-body)
+ (session org-babel-ocaml-eoe-output nil full-body)
(insert
(concat
(org-babel-chomp full-body) ";;\n"
@@ -80,32 +79,31 @@
(progn (setq out nil) line)
(when (string-match re line)
(progn (setq out t) nil))))
- (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\\| \\)\\(.+\\)$"
+ (mapcar #'org-trim (reverse raw)))))))
+ (raw (org-trim clean))
+ (result-params (cdr (assq :result-params params))))
+ (string-match
+ "\\(\\(.*\n\\)*\\)[^:\n]+ : \\([^=\n]+\\) =\\(\n\\| \\)\\(.+\\)$"
+ raw)
+ (let ((output (match-string 1 raw))
+ (type (match-string 3 raw))
+ (value (match-string 5 raw)))
+ (org-babel-reassemble-table
+ (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))
- (output (match-string 1 raw))
- (type (match-string 3 raw))
- (value (match-string 5 raw)))
- (org-babel-reassemble-table
- (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
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+ (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)))))))
(defvar tuareg-interactive-buffer-name)
-(defun org-babel-prep-session:ocaml (session params)
+(defun org-babel-prep-session:ocaml (session _params)
"Prepare SESSION according to the header arguments in PARAMS."
(require 'tuareg)
(let ((tuareg-interactive-buffer-name (if (and (not (string= session "none"))
@@ -123,7 +121,7 @@
(mapcar
(lambda (pair) (format "let %s = %s;;" (car pair)
(org-babel-ocaml-elisp-to-ocaml (cdr pair))))
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
(defun org-babel-ocaml-elisp-to-ocaml (val)
"Return a string of ocaml code which evaluates to VAL."
diff --git a/lisp/ob-octave.el b/lisp/ob-octave.el
index fba5a01..09b4092 100644
--- a/lisp/ob-octave.el
+++ b/lisp/ob-octave.el
@@ -1,4 +1,4 @@
-;;; ob-octave.el --- org-babel functions for octave and matlab evaluation
+;;; ob-octave.el --- Babel Functions for Octave and Matlab -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -30,10 +30,10 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
(declare-function matlab-shell "ext:matlab-mode")
(declare-function matlab-shell-run-region "ext:matlab-mode")
+(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-default-header-args:matlab '())
(defvar org-babel-default-header-args:octave '())
@@ -74,11 +74,8 @@ end")
(let* ((session
(funcall (intern (format "org-babel-%s-initiate-session"
(if matlabp "matlab" "octave")))
- (cdr (assoc :session params)) params))
- (vars (mapcar #'cdr (org-babel-get-header params :var)))
- (result-params (cdr (assoc :result-params params)))
- (result-type (cdr (assoc :result-type params)))
- (out-file (cdr (assoc :file params)))
+ (cdr (assq :session params)) params))
+ (result-type (cdr (assq :result-type params)))
(full-body
(org-babel-expand-body:generic
body params (org-babel-variable-assignments:octave params)))
@@ -99,9 +96,9 @@ end")
(org-babel-reassemble-table
result
(org-babel-pick-name
- (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
(defun org-babel-prep-session:matlab (session params)
"Prepare SESSION according to PARAMS."
@@ -114,7 +111,7 @@ end")
(format "%s=%s;"
(car pair)
(org-babel-octave-var-to-octave (cdr pair))))
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
(defalias 'org-babel-variable-assignments:matlab
'org-babel-variable-assignments:octave)
@@ -148,7 +145,7 @@ If there is not a current inferior-process-buffer in SESSION then
create. Return the initialized session."
(org-babel-octave-initiate-session session params 'matlab))
-(defun org-babel-octave-initiate-session (&optional session params matlabp)
+(defun org-babel-octave-initiate-session (&optional session _params matlabp)
"Create an octave inferior process buffer.
If there is not a current inferior-process-buffer in SESSION then
create. Return the initialized session."
@@ -180,9 +177,9 @@ value of the last statement in BODY, as elisp."
(let ((cmd (if matlabp
org-babel-matlab-shell-command
org-babel-octave-shell-command)))
- (case result-type
- (output (org-babel-eval cmd body))
- (value (let ((tmp-file (org-babel-temp-file "octave-")))
+ (pcase result-type
+ (`output (org-babel-eval cmd body))
+ (`value (let ((tmp-file (org-babel-temp-file "octave-")))
(org-babel-eval
cmd
(format org-babel-octave-wrapper-method body
@@ -191,17 +188,17 @@ value of the last statement in BODY, as elisp."
(org-babel-octave-import-elisp-from-file tmp-file))))))
(defun org-babel-octave-evaluate-session
- (session body result-type &optional matlabp)
+ (session body result-type &optional matlabp)
"Evaluate BODY in SESSION."
(let* ((tmp-file (org-babel-temp-file (if matlabp "matlab-" "octave-")))
(wait-file (org-babel-temp-file "matlab-emacs-link-wait-signal-"))
(full-body
- (case result-type
- (output
+ (pcase result-type
+ (`output
(mapconcat
#'org-babel-chomp
(list body org-babel-octave-eoe-indicator) "\n"))
- (value
+ (`value
(if (and matlabp org-babel-matlab-with-emacs-link)
(concat
(format org-babel-matlab-emacs-link-wrapper-method
@@ -234,21 +231,20 @@ value of the last statement in BODY, as elisp."
org-babel-octave-eoe-output)
t full-body)
(insert full-body) (comint-send-input nil t)))) results)
- (case result-type
- (value
+ (pcase result-type
+ (`value
(org-babel-octave-import-elisp-from-file tmp-file))
- (output
- (progn
- (setq results
- (if matlabp
- (cdr (reverse (delq "" (mapcar
- #'org-babel-octave-read-string
- (mapcar #'org-babel-trim raw)))))
- (cdr (member org-babel-octave-eoe-output
- (reverse (mapcar
- #'org-babel-octave-read-string
- (mapcar #'org-babel-trim raw)))))))
- (mapconcat #'identity (reverse results) "\n"))))))
+ (`output
+ (setq results
+ (if matlabp
+ (cdr (reverse (delq "" (mapcar
+ #'org-babel-strip-quotes
+ (mapcar #'org-trim raw)))))
+ (cdr (member org-babel-octave-eoe-output
+ (reverse (mapcar
+ #'org-babel-strip-quotes
+ (mapcar #'org-trim raw)))))))
+ (mapconcat #'identity (reverse results) "\n")))))
(defun org-babel-octave-import-elisp-from-file (file-name)
"Import data from FILE-NAME.
@@ -263,12 +259,6 @@ This removes initial blank and comment lines and then calls
(delete-region beg end)))
(org-babel-import-elisp-from-file temp-file '(16))))
-(defun org-babel-octave-read-string (string)
- "Strip \\\"s from around octave string."
- (if (string-match "^\"\\([^\000]+\\)\"$" string)
- (match-string 1 string)
- string))
-
(provide 'ob-octave)
diff --git a/lisp/ob-org.el b/lisp/ob-org.el
index af5b548..580d2b0 100644
--- a/lisp/ob-org.el
+++ b/lisp/ob-org.el
@@ -1,4 +1,4 @@
-;;; ob-org.el --- org-babel functions for org code block evaluation
+;;; ob-org.el --- Babel Functions for Org Code Blocks -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -41,7 +41,7 @@
"Default header inserted during export of org blocks.")
(defun org-babel-expand-body:org (body params)
- (dolist (var (mapcar #'cdr (org-babel-get-header params :var)))
+ (dolist (var (org-babel--get-vars params))
(setq body (replace-regexp-in-string
(regexp-quote (format "$%s" (car var)))
(format "%s" (cdr var))
@@ -51,7 +51,7 @@
(defun org-babel-execute:org (body params)
"Execute a block of Org code with.
This function is called by `org-babel-execute-src-block'."
- (let ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (let ((result-params (split-string (or (cdr (assq :results params)) "")))
(body (org-babel-expand-body:org
(replace-regexp-in-string "^," "" body) params)))
(cond
@@ -61,7 +61,7 @@ This function is called by `org-babel-execute-src-block'."
((member "ascii" result-params) (org-export-string-as body 'ascii t))
(t body))))
-(defun org-babel-prep-session:org (session params)
+(defun org-babel-prep-session:org (_session _params)
"Return an error because org does not support sessions."
(error "Org does not support sessions"))
diff --git a/lisp/ob-perl.el b/lisp/ob-perl.el
index 3a63837..a1aadbb 100644
--- a/lisp/ob-perl.el
+++ b/lisp/ob-perl.el
@@ -1,4 +1,4 @@
-;;; ob-perl.el --- org-babel functions for perl evaluation
+;;; ob-perl.el --- Babel Functions for Perl -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -28,7 +28,6 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("perl" . "pl"))
@@ -41,20 +40,20 @@
(defun org-babel-execute:perl (body params)
"Execute a block of Perl code with Babel.
This function is called by `org-babel-execute-src-block'."
- (let* ((session (cdr (assoc :session params)))
- (result-params (cdr (assoc :result-params params)))
- (result-type (cdr (assoc :result-type params)))
+ (let* ((session (cdr (assq :session params)))
+ (result-params (cdr (assq :result-params params)))
+ (result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:perl params)))
(session (org-babel-perl-initiate-session session)))
(org-babel-reassemble-table
(org-babel-perl-evaluate session full-body result-type result-params)
(org-babel-pick-name
- (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
-(defun org-babel-prep-session:perl (session params)
+(defun org-babel-prep-session:perl (_session _params)
"Prepare SESSION according to the header arguments in PARAMS."
(error "Sessions are not supported for Perl"))
@@ -63,7 +62,7 @@ This function is called by `org-babel-execute-src-block'."
(mapcar
(lambda (pair)
(org-babel-perl--var-to-perl (cdr pair) (car pair)))
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
;; helper functions
@@ -76,7 +75,7 @@ This function is called by `org-babel-execute-src-block'."
The elisp value, VAR, is converted to a string of perl source code
specifying a var of the same value."
(if varn
- (let ((org-babel-perl--lvl 0) (lvar (listp var)) prefix)
+ (let ((org-babel-perl--lvl 0) (lvar (listp var)))
(concat "my $" (symbol-name varn) "=" (when lvar "\n")
(org-babel-perl--var-to-perl var)
";\n"))
@@ -92,7 +91,7 @@ specifying a var of the same value."
(defvar org-babel-perl-buffers '(:default . nil))
-(defun org-babel-perl-initiate-session (&optional session params)
+(defun org-babel-perl-initiate-session (&optional _session _params)
"Return nil because sessions are not supported by perl."
nil)
@@ -136,13 +135,13 @@ return the value of the last statement in BODY, as elisp."
(tmp-babel-file (org-babel-process-file-name
tmp-file 'noquote)))
(let ((results
- (case result-type
- (output
+ (pcase result-type
+ (`output
(with-temp-file tmp-file
(insert
(org-babel-eval org-babel-perl-command body))
(buffer-string)))
- (value
+ (`value
(org-babel-eval org-babel-perl-command
(format org-babel-perl-wrapper-method
body tmp-babel-file))))))
diff --git a/lisp/ob-picolisp.el b/lisp/ob-picolisp.el
index 2a4ddc0..348b1f6 100644
--- a/lisp/ob-picolisp.el
+++ b/lisp/ob-picolisp.el
@@ -1,4 +1,4 @@
-;;; ob-picolisp.el --- org-babel functions for picolisp evaluation
+;;; ob-picolisp.el --- Babel Functions for Picolisp -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -55,7 +55,6 @@
;;; Code:
(require 'ob)
(require 'comint)
-(eval-when-compile (require 'cl))
(declare-function run-picolisp "ext:inferior-picolisp" (cmd))
(defvar org-babel-tangle-lang-exts) ;; Autoloaded
@@ -80,9 +79,9 @@
(defun org-babel-expand-body:picolisp (body params)
"Expand BODY according to PARAMS, return the expanded body."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))
- (result-params (cdr (assoc :result-params params)))
- (print-level nil) (print-length nil))
+ (let ((vars (org-babel--get-vars params))
+ (print-level nil)
+ (print-length nil))
(if (> (length vars) 0)
(concat "(prog (let ("
(mapconcat
@@ -100,12 +99,11 @@
(message "executing Picolisp source code block")
(let* (
;; Name of the session or "none".
- (session-name (cdr (assoc :session params)))
+ (session-name (cdr (assq :session params)))
;; Set the session if the session variable is non-nil.
(session (org-babel-picolisp-initiate-session session-name))
;; Either OUTPUT or VALUE which should behave as described above.
- (result-type (cdr (assoc :result-type params)))
- (result-params (cdr (assoc :result-params params)))
+ (result-params (cdr (assq :result-params params)))
;; Expand the body with `org-babel-expand-body:picolisp'.
(full-body (org-babel-expand-body:picolisp body params))
;; Wrap body appropriately for the type of evaluation and results.
diff --git a/lisp/ob-plantuml.el b/lisp/ob-plantuml.el
index 9a0604c..9ce65a9 100644
--- a/lisp/ob-plantuml.el
+++ b/lisp/ob-plantuml.el
@@ -1,4 +1,4 @@
-;;; ob-plantuml.el --- org-babel functions for plantuml evaluation
+;;; ob-plantuml.el --- Babel Functions for Plantuml -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -49,21 +49,36 @@
(defun org-babel-execute:plantuml (body params)
"Execute a block of plantuml code with org-babel.
This function is called by `org-babel-execute-src-block'."
- (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
- (out-file (or (cdr (assoc :file params))
+ (let* ((out-file (or (cdr (assq :file params))
(error "PlantUML requires a \":file\" header argument")))
- (cmdline (cdr (assoc :cmdline params)))
+ (cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "plantuml-"))
- (java (or (cdr (assoc :java params)) ""))
+ (java (or (cdr (assq :java params)) ""))
(cmd (if (string= "" org-plantuml-jar-path)
(error "`org-plantuml-jar-path' is not set")
(concat "java " java " -jar "
(shell-quote-argument
(expand-file-name org-plantuml-jar-path))
+ (if (string= (file-name-extension out-file) "png")
+ " -tpng" "")
(if (string= (file-name-extension out-file) "svg")
" -tsvg" "")
(if (string= (file-name-extension out-file) "eps")
" -teps" "")
+ (if (string= (file-name-extension out-file) "pdf")
+ " -tpdf" "")
+ (if (string= (file-name-extension out-file) "vdx")
+ " -tvdx" "")
+ (if (string= (file-name-extension out-file) "xmi")
+ " -txmi" "")
+ (if (string= (file-name-extension out-file) "scxml")
+ " -tscxml" "")
+ (if (string= (file-name-extension out-file) "html")
+ " -thtml" "")
+ (if (string= (file-name-extension out-file) "txt")
+ " -ttxt" "")
+ (if (string= (file-name-extension out-file) "utxt")
+ " -utxt" "")
" -p " cmdline " < "
(org-babel-process-file-name in-file)
" > "
@@ -74,7 +89,7 @@ This function is called by `org-babel-execute-src-block'."
(message "%s" cmd) (org-babel-eval cmd "")
nil)) ;; signal that output has already been written to file
-(defun org-babel-prep-session:plantuml (session params)
+(defun org-babel-prep-session:plantuml (_session _params)
"Return an error because plantuml does not support sessions."
(error "Plantuml does not support sessions"))
diff --git a/lisp/ob-processing.el b/lisp/ob-processing.el
index 2410402..e1801e2 100644
--- a/lisp/ob-processing.el
+++ b/lisp/ob-processing.el
@@ -1,4 +1,4 @@
-;;; ob-processing.el --- Babel functions for evaluation of processing
+;;; ob-processing.el --- Babel functions for processing -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
@@ -52,7 +52,6 @@
;;; Code:
(require 'ob)
(require 'sha1)
-(eval-when-compile (require 'cl))
(declare-function processing-sketch-run "ext:processing-mode" ())
@@ -96,7 +95,7 @@
(progn
(setq sketch-dir-candidate
(make-temp-file "processing" t))
- (when (org-string-match-p
+ (when (string-match-p
"-"
(file-name-nondirectory sketch-dir-candidate))
(delete-directory sketch-dir-candidate)
@@ -134,7 +133,7 @@ This function is called by `org-babel-execute-src-block'."
sketch-canvas-id
"\"></canvas>"))))
-(defun org-babel-prep-session:processing (session params)
+(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"))
@@ -142,7 +141,7 @@ 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))))
+ (org-babel--get-vars params)))
(defun org-babel-processing-var-to-processing (pair)
"Convert an elisp value into a Processing variable.
@@ -179,17 +178,16 @@ a variable of the same value."
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)))))))
+The type is `String' if any element in DATA is a string.
+Otherwise, it is either `float', if some elements are floats, or
+`int'."
+ (letrec ((type 'int)
+ (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)
diff --git a/lisp/ob-python.el b/lisp/ob-python.el
index 1932e61..05f2dbb 100644
--- a/lisp/ob-python.el
+++ b/lisp/ob-python.el
@@ -1,4 +1,4 @@
-;;; ob-python.el --- org-babel functions for python evaluation
+;;; ob-python.el --- Babel Functions for Python -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -28,12 +28,12 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
(declare-function org-remove-indentation "org" )
+(declare-function org-trim "org" (s &optional keep-lead))
(declare-function py-shell "ext:python-mode" (&optional argprompt))
(declare-function py-toggle-shells "ext:python-mode" (arg))
-(declare-function run-python "ext:python" (cmd &optional dedicated show))
+(declare-function run-python "ext:python" (&optional cmd dedicated show))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("python" . "py"))
@@ -48,7 +48,7 @@
:type 'string)
(defcustom org-babel-python-mode
- (if (or (featurep 'xemacs) (featurep 'python-mode)) 'python-mode 'python)
+ (if (featurep 'python-mode) 'python-mode 'python)
"Preferred python mode for use in running python interactively.
This will typically be either `python' or `python-mode'."
:group 'org-babel
@@ -74,14 +74,14 @@ This will typically be either `python' or `python-mode'."
"Execute a block of Python code with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-python-initiate-session
- (cdr (assoc :session params))))
- (result-params (cdr (assoc :result-params params)))
- (result-type (cdr (assoc :result-type params)))
+ (cdr (assq :session params))))
+ (result-params (cdr (assq :result-params params)))
+ (result-type (cdr (assq :result-type params)))
(return-val (when (and (eq result-type 'value) (not session))
- (cdr (assoc :return params))))
- (preamble (cdr (assoc :preamble params)))
+ (cdr (assq :return params))))
+ (preamble (cdr (assq :preamble params)))
(org-babel-python-command
- (or (cdr (assoc :python params)) org-babel-python-command))
+ (or (cdr (assq :python params)) org-babel-python-command))
(full-body
(org-babel-expand-body:generic
(concat body (if return-val (format "\nreturn %s" return-val) ""))
@@ -90,10 +90,10 @@ This function is called by `org-babel-execute-src-block'."
session full-body result-type result-params preamble)))
(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))))))
+ (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))))))
(defun org-babel-prep-session:python (session params)
"Prepare SESSION according to the header arguments in PARAMS.
@@ -125,7 +125,7 @@ VARS contains resolved variable references"
(format "%s=%s"
(car pair)
(org-babel-python-var-to-python (cdr pair))))
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
(defun org-babel-python-var-to-python (var)
"Convert an elisp value to a python variable.
@@ -133,7 +133,7 @@ Convert an elisp value, VAR, into a string of python source code
specifying a variable of the same value."
(if (listp var)
(concat "[" (mapconcat #'org-babel-python-var-to-python var ", ") "]")
- (if (equal var 'hline)
+ (if (eq var 'hline)
org-babel-python-hline-to
(format
(if (and (stringp var) (string-match "[\n\r]" var)) "\"\"%S\"\"" "%S")
@@ -145,7 +145,7 @@ If the results look like a list or tuple, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(let ((res (org-babel-script-escape results)))
(if (listp res)
- (mapcar (lambda (el) (if (equal el 'None)
+ (mapcar (lambda (el) (if (eq el 'None)
org-babel-python-None-to el))
res)
res)))
@@ -216,7 +216,7 @@ then create. Return the initialized session."
(assq-delete-all session org-babel-python-buffers)))
session)))
-(defun org-babel-python-initiate-session (&optional session params)
+(defun org-babel-python-initiate-session (&optional session _params)
"Create a session named SESSION according to PARAMS."
(unless (string= session "none")
(org-babel-python-session-buffer
@@ -248,36 +248,35 @@ open('%s', 'w').write( pprint.pformat(main()) )")
body result-type result-params preamble)))
(defun org-babel-python-evaluate-external-process
- (body &optional result-type result-params preamble)
+ (body &optional result-type result-params preamble)
"Evaluate BODY in external python 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."
(let ((raw
- (case result-type
- (output (org-babel-eval org-babel-python-command
- (concat (if preamble (concat preamble "\n"))
- body)))
- (value (let ((tmp-file (org-babel-temp-file "python-")))
- (org-babel-eval
- org-babel-python-command
- (concat
- (if preamble (concat preamble "\n") "")
- (format
- (if (member "pp" result-params)
- org-babel-python-pp-wrapper-method
- org-babel-python-wrapper-method)
- (mapconcat
- (lambda (line) (format "\t%s" line))
- (split-string
- (org-remove-indentation
- (org-babel-trim body))
- "[\r\n]") "\n")
- (org-babel-process-file-name tmp-file 'noquote))))
- (org-babel-eval-read-file tmp-file))))))
+ (pcase result-type
+ (`output (org-babel-eval org-babel-python-command
+ (concat (if preamble (concat preamble "\n"))
+ body)))
+ (`value (let ((tmp-file (org-babel-temp-file "python-")))
+ (org-babel-eval
+ org-babel-python-command
+ (concat
+ (if preamble (concat preamble "\n") "")
+ (format
+ (if (member "pp" result-params)
+ org-babel-python-pp-wrapper-method
+ org-babel-python-wrapper-method)
+ (mapconcat
+ (lambda (line) (format "\t%s" line))
+ (split-string (org-remove-indentation (org-trim body))
+ "[\r\n]")
+ "\n")
+ (org-babel-process-file-name tmp-file 'noquote))))
+ (org-babel-eval-read-file tmp-file))))))
(org-babel-result-cond result-params
raw
- (org-babel-python-table-or-string (org-babel-trim raw)))))
+ (org-babel-python-table-or-string (org-trim raw)))))
(defun org-babel-python-evaluate-session
(session body &optional result-type result-params)
@@ -304,10 +303,10 @@ last statement in BODY, as elisp."
(split-string body "[\r\n]"))
(funcall send-wait)))
(results
- (case result-type
- (output
+ (pcase result-type
+ (`output
(mapconcat
- #'org-babel-trim
+ #'org-trim
(butlast
(org-babel-comint-with-output
(session org-babel-python-eoe-indicator t body)
@@ -316,7 +315,7 @@ last statement in BODY, as elisp."
(insert org-babel-python-eoe-indicator)
(funcall send-wait))
2) "\n"))
- (value
+ (`value
(let ((tmp-file (org-babel-temp-file "python-")))
(org-babel-comint-with-output
(session org-babel-python-eoe-indicator nil body)
@@ -335,8 +334,9 @@ last statement in BODY, as elisp."
(defun org-babel-python-read-string (string)
"Strip \\='s from around Python string."
- (if (string-match "^'\\([^\000]+\\)'$" string)
- (match-string 1 string)
+ (if (and (string-prefix-p "'" string)
+ (string-suffix-p "'" string))
+ (substring string 1 -1)
string))
(provide 'ob-python)
diff --git a/lisp/ob-ref.el b/lisp/ob-ref.el
index 95eb114..c109d89 100644
--- a/lisp/ob-ref.el
+++ b/lisp/ob-ref.el
@@ -1,4 +1,4 @@
-;;; ob-ref.el --- org-babel functions for referencing external data
+;;; ob-ref.el --- Babel Functions for Referencing External Data -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -50,23 +50,20 @@
;;; Code:
(require 'ob-core)
-(eval-when-compile
- (require 'cl))
+(require 'cl-lib)
+(declare-function org-babel-lob-get-info "ob-lob" (&optional datum))
+(declare-function org-element-at-point "org-element" ())
+(declare-function org-element-property "org-element" (property element))
+(declare-function org-element-type "org-element" (element))
(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))
-(declare-function org-at-item-p "org-list" ())
-(declare-function org-narrow-to-subtree "org" ())
-(declare-function org-id-find-id-in-file "org-id" (id file &optional markerp))
(declare-function org-id-find-id-file "org-id" (id))
+(declare-function org-id-find-id-in-file "org-id" (id file &optional markerp))
+(declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
+(declare-function org-narrow-to-subtree "org" ())
(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)
+(declare-function org-trim "org" (s &optional keep-lead))
(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]*")
@@ -94,7 +91,8 @@ the variable."
org-babel-current-src-block-location)))
(org-babel-read ref))))
(if (equal out ref)
- (if (string-match "^\".*\"$" ref)
+ (if (and (string-prefix-p "\"" ref)
+ (string-suffix-p "\"" ref))
(read ref)
(org-babel-ref-resolve ref))
out))))))
@@ -106,7 +104,7 @@ the variable."
(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))
+ (pop-to-buffer-same-window (marker-buffer m))
(goto-char m)
(move-marker m nil)
(org-show-context)
@@ -121,7 +119,6 @@ the variable."
(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."
@@ -129,12 +126,12 @@ the variable."
(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)
+ args new-refere new-header-args new-referent split-file split-ref
+ index)
;; 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))))
+ (= (cl-count ?( str) (cl-count ?) str))))
(setq index (match-string 1 ref))
(setq ref (substring ref 0 (match-beginning 0))))
;; assign any arguments to pass to source block
@@ -154,71 +151,54 @@ the variable."
(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))))))))
+ (find-file split-file)
+ (setq ref split-ref))
+ (org-with-wide-buffer
+ (goto-char (point-min))
+ (let* ((params (append args '((:results . "silent"))))
+ (regexp (org-babel-named-data-regexp-for-name ref))
+ (result
+ (catch :found
+ ;; Check for code blocks or named data.
+ (while (re-search-forward regexp nil t)
+ ;; Ignore COMMENTed headings and orphaned
+ ;; affiliated keywords.
+ (unless (org-in-commented-heading-p)
+ (let ((e (org-element-at-point)))
+ (when (equal (org-element-property :name e) ref)
+ (goto-char
+ (org-element-property :post-affiliated e))
+ (pcase (org-element-type e)
+ (`babel-call
+ (throw :found
+ (org-babel-execute-src-block
+ nil (org-babel-lob-get-info e) params)))
+ (`src-block
+ (throw :found
+ (org-babel-execute-src-block
+ nil nil
+ (and
+ (not org-babel-update-intermediate)
+ params))))
+ ((and (let v (org-babel-read-element e))
+ (guard v))
+ (throw :found v))
+ (_ (error "Reference not found")))))))
+ ;; Check for local or global headlines by ID.
+ (when (org-babel-ref-goto-headline-id ref)
+ (throw :found (org-babel-ref-headline-body)))
+ ;; Check the Library of Babel.
+ (let ((info (cdr (assq (intern ref)
+ org-babel-library-of-babel))))
+ (when info
+ (throw :found
+ (org-babel-execute-src-block nil info params))))
+ (error "Reference `%s' not found in this buffer" ref))))
+ (cond
+ ((symbolp result) (format "%S" result))
+ ((and index (listp result))
+ (org-babel-ref-index-list index result))
+ (t result)))))))))
(defun org-babel-ref-index-list (index lis)
"Return the subset of LIS indexed by INDEX.
@@ -261,21 +241,9 @@ to \"0:-1\"."
(defun org-babel-ref-split-args (arg-string)
"Split ARG-STRING into top-level arguments of balanced parenthesis."
- (mapcar #'org-babel-trim (org-babel-balanced-split arg-string 44)))
+ (mapcar #'org-trim (org-babel-balanced-split arg-string 44)))
-(defvar org-bracket-link-regexp)
-(defun org-babel-ref-at-ref-p ()
- "Return the type of reference located at point.
-Return nil if none of the supported reference types are found.
-Supported reference types are tables and source blocks."
- (cond ((org-at-table-p) 'table)
- ((org-at-item-p) 'list)
- ((looking-at "^[ \t]*#\\+BEGIN_SRC") 'source-block)
- ((looking-at org-bracket-link-regexp) 'file)
- ((looking-at org-babel-result-regexp) 'results-line)))
(provide 'ob-ref)
-
-
;;; ob-ref.el ends here
diff --git a/lisp/ob-ruby.el b/lisp/ob-ruby.el
index 0cc665d..6415f35 100644
--- a/lisp/ob-ruby.el
+++ b/lisp/ob-ruby.el
@@ -1,4 +1,4 @@
-;;; ob-ruby.el --- org-babel functions for ruby evaluation
+;;; ob-ruby.el --- Babel Functions for Ruby -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -37,8 +37,8 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
+(declare-function org-trim "org" (s &optional keep-lead))
(declare-function run-ruby "ext:inf-ruby" (&optional command name))
(declare-function xmp "ext:rcodetools" (&optional option))
@@ -68,16 +68,16 @@
"Execute a block of Ruby code with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-ruby-initiate-session
- (cdr (assoc :session params))))
- (result-params (cdr (assoc :result-params params)))
- (result-type (cdr (assoc :result-type params)))
+ (cdr (assq :session params))))
+ (result-params (cdr (assq :result-params params)))
+ (result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:ruby params)))
(result (if (member "xmp" result-params)
(with-temp-buffer
(require 'rcodetools)
(insert full-body)
- (xmp (cdr (assoc :xmp-option params)))
+ (xmp (cdr (assq :xmp-option params)))
(buffer-string))
(org-babel-ruby-evaluate
session full-body result-type result-params))))
@@ -85,10 +85,10 @@ This function is called by `org-babel-execute-src-block'."
(org-babel-result-cond result-params
result
(org-babel-ruby-table-or-string 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))))))
+ (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))))))
(defun org-babel-prep-session:ruby (session params)
"Prepare SESSION according to the header arguments specified in PARAMS."
@@ -121,7 +121,7 @@ This function is called by `org-babel-execute-src-block'."
(format "%s=%s"
(car pair)
(org-babel-ruby-var-to-ruby (cdr pair))))
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
(defun org-babel-ruby-var-to-ruby (var)
"Convert VAR into a ruby variable.
@@ -129,7 +129,7 @@ Convert an elisp value into a string of ruby source code
specifying a variable of the same value."
(if (listp var)
(concat "[" (mapconcat #'org-babel-ruby-var-to-ruby var ", ") "]")
- (if (equal var 'hline)
+ (if (eq var 'hline)
org-babel-ruby-hline-to
(format "%S" var))))
@@ -139,12 +139,12 @@ If RESULTS look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(let ((res (org-babel-script-escape results)))
(if (listp res)
- (mapcar (lambda (el) (if (equal el 'nil)
- org-babel-ruby-nil-to el))
+ (mapcar (lambda (el) (if (not el)
+ org-babel-ruby-nil-to el))
res)
res)))
-(defun org-babel-ruby-initiate-session (&optional session params)
+(defun org-babel-ruby-initiate-session (&optional session _params)
"Initiate a ruby session.
If there is not a current inferior-process-buffer in SESSION
then create one. Return the initialized session."
@@ -185,26 +185,26 @@ end
")
(defun org-babel-ruby-evaluate
- (buffer body &optional result-type result-params)
+ (buffer body &optional result-type result-params)
"Pass BODY to the Ruby 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, as elisp."
(if (not buffer)
;; external process evaluation
- (case result-type
- (output (org-babel-eval org-babel-ruby-command body))
- (value (let ((tmp-file (org-babel-temp-file "ruby-")))
- (org-babel-eval
- org-babel-ruby-command
- (format (if (member "pp" result-params)
- org-babel-ruby-pp-wrapper-method
- org-babel-ruby-wrapper-method)
- body (org-babel-process-file-name tmp-file 'noquote)))
- (org-babel-eval-read-file tmp-file))))
+ (pcase result-type
+ (`output (org-babel-eval org-babel-ruby-command body))
+ (`value (let ((tmp-file (org-babel-temp-file "ruby-")))
+ (org-babel-eval
+ org-babel-ruby-command
+ (format (if (member "pp" result-params)
+ org-babel-ruby-pp-wrapper-method
+ org-babel-ruby-wrapper-method)
+ body (org-babel-process-file-name tmp-file 'noquote)))
+ (org-babel-eval-read-file tmp-file))))
;; comint session evaluation
- (case result-type
- (output
+ (pcase result-type
+ (`output
(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
@@ -220,7 +220,7 @@ return the value of the last statement in BODY, as elisp."
(butlast
(split-string
(mapconcat
- #'org-babel-trim
+ #'org-trim
(org-babel-comint-with-output
(buffer org-babel-ruby-eoe-indicator t body)
(mapc
@@ -231,7 +231,7 @@ return the value of the last statement in BODY, as elisp."
"conf.prompt_mode=_org_prompt_mode;conf.echo=true"
eoe-string)))
"\n") "[\r\n]") 4) "\n")))
- (value
+ (`value
(let* ((tmp-file (org-babel-temp-file "ruby-"))
(ppp (or (member "code" result-params)
(member "pp" result-params))))
@@ -254,12 +254,6 @@ return the value of the last statement in BODY, as elisp."
(comint-send-input nil t))
(org-babel-eval-read-file tmp-file))))))
-(defun org-babel-ruby-read-string (string)
- "Strip \\\"s from around a ruby string."
- (if (string-match "^\"\\([^\000]+\\)\"$" string)
- (match-string 1 string)
- string))
-
(provide 'ob-ruby)
diff --git a/lisp/ob-sass.el b/lisp/ob-sass.el
index f675914..53fb45e 100644
--- a/lisp/ob-sass.el
+++ b/lisp/ob-sass.el
@@ -1,4 +1,4 @@
-;;; ob-sass.el --- org-babel functions for the sass css generation language
+;;; ob-sass.el --- Babel Functions for the Sass CSS generation language -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -45,10 +45,9 @@
(defun org-babel-execute:sass (body params)
"Execute a block of Sass code with Babel.
This function is called by `org-babel-execute-src-block'."
- (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
- (file (cdr (assoc :file params)))
+ (let* ((file (cdr (assq :file params)))
(out-file (or file (org-babel-temp-file "sass-out-")))
- (cmdline (cdr (assoc :cmdline params)))
+ (cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "sass-in-"))
(cmd (concat "sass " (or cmdline "")
" " (org-babel-process-file-name in-file)
@@ -60,7 +59,7 @@ This function is called by `org-babel-execute-src-block'."
nil ;; signal that output has already been written to file
(with-temp-buffer (insert-file-contents out-file) (buffer-string)))))
-(defun org-babel-prep-session:sass (session params)
+(defun org-babel-prep-session:sass (_session _params)
"Raise an error because sass does not support sessions."
(error "Sass does not support sessions"))
diff --git a/lisp/ob-scala.el b/lisp/ob-scala.el
index 7df8da8..8cdf2c0 100644
--- a/lisp/ob-scala.el
+++ b/lisp/ob-scala.el
@@ -1,4 +1,4 @@
-;;; ob-scala.el --- org-babel functions for Scala evaluation
+;;; ob-scala.el --- Babel Functions for Scala -*- lexical-binding: t; -*-
;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
@@ -31,7 +31,6 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
(defvar org-babel-tangle-lang-exts) ;; Autoloaded
(add-to-list 'org-babel-tangle-lang-exts '("scala" . "scala"))
@@ -45,9 +44,8 @@ called by `org-babel-execute-src-block'"
(message "executing Scala source code block")
(let* ((processed-params (org-babel-process-params params))
(session (org-babel-scala-initiate-session (nth 0 processed-params)))
- (vars (nth 1 processed-params))
(result-params (nth 2 processed-params))
- (result-type (cdr (assoc :result-type params)))
+ (result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params))
(result (org-babel-scala-evaluate
@@ -56,9 +54,9 @@ called by `org-babel-execute-src-block'"
(org-babel-reassemble-table
result
(org-babel-pick-name
- (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defvar org-babel-scala-wrapper-method
@@ -76,19 +74,19 @@ print(str_result)
(defun org-babel-scala-evaluate
- (session body &optional result-type result-params)
+ (session body &optional result-type result-params)
"Evaluate BODY in external Scala 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 Scala"))
- (case result-type
- (output
+ (pcase result-type
+ (`output
(let ((src-file (org-babel-temp-file "scala-")))
- (progn (with-temp-file src-file (insert body))
- (org-babel-eval
- (concat org-babel-scala-command " " src-file) ""))))
- (value
+ (with-temp-file src-file (insert body))
+ (org-babel-eval
+ (concat org-babel-scala-command " " src-file) "")))
+ (`value
(let* ((src-file (org-babel-temp-file "scala-"))
(wrapper (format org-babel-scala-wrapper-method body)))
(with-temp-file src-file (insert wrapper))
@@ -99,11 +97,11 @@ in BODY as elisp."
(org-babel-script-escape raw)))))))
-(defun org-babel-prep-session:scala (session params)
+(defun org-babel-prep-session:scala (_session _params)
"Prepare SESSION according to the header arguments specified in PARAMS."
(error "Sessions are not (yet) supported for Scala"))
-(defun org-babel-scala-initiate-session (&optional session)
+(defun org-babel-scala-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 Scala."
diff --git a/lisp/ob-scheme.el b/lisp/ob-scheme.el
index 0473138..c1d5462 100644
--- a/lisp/ob-scheme.el
+++ b/lisp/ob-scheme.el
@@ -1,4 +1,4 @@
-;;; ob-scheme.el --- org-babel functions for Scheme
+;;; ob-scheme.el --- Babel Functions for Scheme -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -45,17 +45,18 @@
(defvar geiser-default-implementation) ; Defined in geiser-impl.el
(defvar geiser-active-implementations) ; Defined in geiser-impl.el
-(declare-function run-geiser "geiser-repl" (impl))
-(declare-function geiser-mode "geiser-mode" ())
-(declare-function geiser-eval-region "geiser-mode" (start end &optional and-go raw nomsg))
-(declare-function geiser-repl-exit "geiser-repl" (&optional arg))
+(declare-function run-geiser "ext:geiser-repl" (impl))
+(declare-function geiser-mode "ext:geiser-mode" ())
+(declare-function geiser-eval-region "ext:geiser-mode"
+ (start end &optional and-go raw nomsg))
+(declare-function geiser-repl-exit "ext:geiser-repl" (&optional arg))
(defvar org-babel-default-header-args:scheme '()
"Default header arguments for scheme code blocks.")
(defun org-babel-expand-body:scheme (body params)
"Expand BODY according to PARAMS, return the expanded body."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(if (> (length vars) 0)
(concat "(let ("
(mapconcat
@@ -172,7 +173,7 @@ is true; otherwise returns the last value."
(setq result (if (or (string= result "#<void>")
(string= result "#<unspecified>"))
nil
- (read result)))))
+ result))))
result))
(defun org-babel-execute:scheme (body params)
@@ -184,23 +185,23 @@ This function is called by `org-babel-execute-src-block'"
(buffer-name source-buffer))))
(save-excursion
(org-babel-reassemble-table
- (let* ((result-type (cdr (assoc :result-type params)))
- (impl (or (when (cdr (assoc :scheme params))
- (intern (cdr (assoc :scheme params))))
+ (let* ((result-type (cdr (assq :result-type params)))
+ (impl (or (when (cdr (assq :scheme params))
+ (intern (cdr (assq :scheme params))))
geiser-default-implementation
(car geiser-active-implementations)))
(session (org-babel-scheme-make-session-name
- source-buffer-name (cdr (assoc :session params)) impl))
+ source-buffer-name (cdr (assq :session params)) impl))
(full-body (org-babel-expand-body:scheme body params)))
(org-babel-scheme-execute-with-geiser
full-body ; code
(string= result-type "output") ; output?
impl ; implementation
(and (not (string= session "none")) session))) ; session
- (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)))))))
+ (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-scheme)
diff --git a/lisp/ob-screen.el b/lisp/ob-screen.el
index db89733..c4c9528 100644
--- a/lisp/ob-screen.el
+++ b/lisp/ob-screen.el
@@ -1,4 +1,4 @@
-;;; ob-screen.el --- org-babel support for interactive terminal
+;;; ob-screen.el --- Babel Support for Interactive Terminal -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -48,18 +48,17 @@ In case you want to use a different screen than one selected by your $PATH")
\"default\" session is used when none is specified."
(message "Sending source code block to interactive terminal session...")
(save-window-excursion
- (let* ((session (cdr (assoc :session params)))
+ (let* ((session (cdr (assq :session params)))
(socket (org-babel-screen-session-socketname session)))
(unless socket (org-babel-prep-session:screen session params))
(org-babel-screen-session-execute-string
session (org-babel-expand-body:generic body params)))))
-(defun org-babel-prep-session:screen (session params)
+(defun org-babel-prep-session:screen (_session params)
"Prepare SESSION according to the header arguments specified in PARAMS."
- (let* ((session (cdr (assoc :session params)))
- (socket (org-babel-screen-session-socketname session))
- (cmd (cdr (assoc :cmd params)))
- (terminal (cdr (assoc :terminal params)))
+ (let* ((session (cdr (assq :session params)))
+ (cmd (cdr (assq :cmd params)))
+ (terminal (cdr (assq :terminal params)))
(process-name (concat "org-babel: terminal (" session ")")))
(apply 'start-process process-name "*Messages*"
terminal `("-T" ,(concat "org-babel: " session) "-e" ,org-babel-screen-location
@@ -104,7 +103,7 @@ In case you want to use a different screen than one selected by your $PATH")
sockets)))))
(when match-socket (car (split-string match-socket)))))
-(defun org-babel-screen-session-write-temp-file (session body)
+(defun org-babel-screen-session-write-temp-file (_session body)
"Save BODY in a temp file that is named after SESSION."
(let ((tmpfile (org-babel-temp-file "screen-")))
(with-temp-file tmpfile
@@ -119,11 +118,10 @@ In case you want to use a different screen than one selected by your $PATH")
"Test if the default setup works.
The terminal should shortly flicker."
(interactive)
- (let* ((session "org-babel-testing")
- (random-string (format "%s" (random 99999)))
+ (let* ((random-string (format "%s" (random 99999)))
(tmpfile (org-babel-temp-file "ob-screen-test-"))
(body (concat "echo '" random-string "' > " tmpfile "\nexit\n"))
- process tmp-string)
+ tmp-string)
(org-babel-execute:screen body org-babel-default-header-args:screen)
;; XXX: need to find a better way to do the following
(while (not (file-readable-p tmpfile))
diff --git a/lisp/ob-sed.el b/lisp/ob-sed.el
index f68bb14..dd8a17b 100644
--- a/lisp/ob-sed.el
+++ b/lisp/ob-sed.el
@@ -1,4 +1,4 @@
-;;; ob-sed.el --- org-babel functions for sed scripts
+;;; ob-sed.el --- Babel Functions for Sed Scripts -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
diff --git a/lisp/ob-shell.el b/lisp/ob-shell.el
index 527e6f5..74b6c7e 100644
--- a/lisp/ob-shell.el
+++ b/lisp/ob-shell.el
@@ -1,4 +1,4 @@
-;;; ob-shell.el --- org-babel functions for shell evaluation
+;;; ob-shell.el --- Babel Functions for Shell Evaluation -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -28,49 +28,60 @@
;;; Code:
(require 'ob)
(require 'shell)
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
-(declare-function org-babel-comint-in-buffer "ob-comint" (buffer &rest body))
+(declare-function org-babel-comint-in-buffer "ob-comint" (buffer &rest body)
+ t)
(declare-function org-babel-comint-wait-for-output "ob-comint" (buffer))
(declare-function org-babel-comint-buffer-livep "ob-comint" (buffer))
-(declare-function org-babel-comint-with-output "ob-comint" (meta &rest body))
+(declare-function org-babel-comint-with-output "ob-comint" (meta &rest body)
+ t)
+(declare-function org-trim "org" (s &optional keep-lead))
(declare-function orgtbl-to-generic "org-table" (table params))
(defvar org-babel-default-header-args:shell '())
+(defvar org-babel-shell-names)
+
+(defun org-babel-shell-initialize ()
+ "Define execution functions associated to shell names.
+This function has to be called whenever `org-babel-shell-names'
+is modified outside the Customize interface."
+ (interactive)
+ (dolist (name org-babel-shell-names)
+ (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))))))
(defcustom org-babel-shell-names
'("sh" "bash" "csh" "ash" "dash" "ksh" "mksh" "posh")
- "List of names of shell supported by babel shell code blocks."
+ "List of names of shell supported by babel shell code blocks.
+Call `org-babel-shell-initialize' when modifying this variable
+outside the Customize interface."
:group 'org-babel
- :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))))
+ :type '(repeat (string :tag "Shell name: "))
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (org-babel-shell-initialize)))
(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
- (cdr (assoc :session params))))
- (stdin (let ((stdin (cdr (assoc :stdin params))))
+ (cdr (assq :session params))))
+ (stdin (let ((stdin (cdr (assq :stdin params))))
(when stdin (org-babel-sh-var-to-string
(org-babel-ref-resolve stdin)))))
- (cmdline (cdr (assoc :cmdline params)))
+ (cmdline (cdr (assq :cmdline params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:shell params))))
(org-babel-reassemble-table
(org-babel-sh-evaluate session full-body params stdin cmdline)
(org-babel-pick-name
- (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defun org-babel-prep-session:shell (session params)
"Prepare SESSION according to the header arguments specified in PARAMS."
@@ -131,18 +142,18 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-variable-assignments:shell (params)
"Return list of shell statements assigning the block's variables."
- (let ((sep (cdr (assoc :separator params)))
- (hline (when (string= "yes" (cdr (assoc :hlines params)))
- (or (cdr (assoc :hline-string params))
+ (let ((sep (cdr (assq :separator params)))
+ (hline (when (string= "yes" (cdr (assq :hlines params)))
+ (or (cdr (assq :hline-string params))
"hline"))))
(mapcar
(lambda (pair)
- (if (string-match "bash$" shell-file-name)
+ (if (string-suffix-p "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)))))
+ (org-babel--get-vars params))))
(defun org-babel-sh-var-to-sh (var &optional sep hline)
"Convert an elisp value to a shell variable.
@@ -157,14 +168,14 @@ var of the same value."
"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)))
+ ((and (listp var) (or (listp (car var)) (eq (car var) 'hline)))
(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-initiate-session (&optional session params)
+(defun org-babel-sh-initiate-session (&optional session _params)
"Initiate a session named SESSION according to PARAMS."
(when (and session (not (string= session "none")))
(save-window-excursion
@@ -192,8 +203,8 @@ return the value of the last statement in BODY."
((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)))
- (padline (not (string= "no" (cdr (assoc :padline params))))))
+ (shebang (cdr (assq :shebang params)))
+ (padline (not (string= "no" (cdr (assq :padline params))))))
(with-temp-file script-file
(when shebang (insert (concat shebang "\n")))
(when padline (insert "\n"))
@@ -212,7 +223,7 @@ return the value of the last statement in BODY."
(mapconcat
#'org-babel-sh-strip-weird-long-prompt
(mapcar
- #'org-babel-trim
+ #'org-trim
(butlast
(org-babel-comint-with-output
(session org-babel-sh-eoe-output t body)
@@ -227,24 +238,24 @@ return the value of the last statement in BODY."
(accept-process-output
(get-buffer-process (current-buffer)))))
(append
- (split-string (org-babel-trim body) "\n")
+ (split-string (org-trim body) "\n")
(list org-babel-sh-eoe-indicator))))
2)) "\n"))
('otherwise ; external shell script
- (if (and (cdr (assoc :shebang params))
- (> (length (cdr (assoc :shebang params))) 0))
+ (if (and (cdr (assq :shebang params))
+ (> (length (cdr (assq :shebang params))) 0))
(let ((script-file (org-babel-temp-file "sh-script-"))
- (shebang (cdr (assoc :shebang params)))
- (padline (not (equal "no" (cdr (assoc :padline params))))))
+ (shebang (cdr (assq :shebang params)))
+ (padline (not (equal "no" (cdr (assq :padline params))))))
(with-temp-file script-file
(when shebang (insert (concat shebang "\n")))
(when padline (insert "\n"))
(insert body))
(set-file-modes script-file #o755)
(org-babel-eval script-file ""))
- (org-babel-eval shell-file-name (org-babel-trim body)))))))
+ (org-babel-eval shell-file-name (org-trim body)))))))
(when results
- (let ((result-params (cdr (assoc :result-params params))))
+ (let ((result-params (cdr (assq :result-params params))))
(org-babel-result-cond result-params
results
(let ((tmp-file (org-babel-temp-file "sh-")))
diff --git a/lisp/ob-shen.el b/lisp/ob-shen.el
index 413fe0d..f502d43 100644
--- a/lisp/ob-shen.el
+++ b/lisp/ob-shen.el
@@ -1,4 +1,4 @@
-;;; ob-shen.el --- org-babel functions for Shen
+;;; ob-shen.el --- Babel Functions for Shen -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -43,7 +43,7 @@
(defun org-babel-expand-body:shen (body params)
"Expand BODY according to PARAMS, return the expanded body."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(if (> (length vars) 0)
(concat "(let "
(mapconcat (lambda (var)
@@ -63,14 +63,13 @@
"Execute a block of Shen code with org-babel.
This function is called by `org-babel-execute-src-block'"
(require 'inf-shen)
- (let* ((result-type (cdr (assoc :result-type params)))
- (result-params (cdr (assoc :result-params params)))
+ (let* ((result-params (cdr (assq :result-params params)))
(full-body (org-babel-expand-body:shen body params)))
(let ((results
(with-temp-buffer
(insert full-body)
(call-interactively #'shen-eval-defun))))
- (org-babel-result-cond result-params
+ (org-babel-result-cond result-params
results
(condition-case nil (org-babel-script-escape results)
(error results))))))
diff --git a/lisp/ob-sql.el b/lisp/ob-sql.el
index f096572..ec94c35 100644
--- a/lisp/ob-sql.el
+++ b/lisp/ob-sql.el
@@ -1,4 +1,4 @@
-;;; ob-sql.el --- org-babel functions for sql evaluation
+;;; ob-sql.el --- Babel Functions for SQL -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -57,11 +57,11 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
(declare-function org-table-import "org-table" (file arg))
(declare-function orgtbl-to-csv "org-table" (table params))
(declare-function org-table-to-lisp "org-table" (&optional txt))
+(declare-function cygwin-convert-file-name-to-windows "cygw32.c" (file &optional absolute-p))
(defvar org-babel-default-header-args:sql '())
@@ -78,7 +78,7 @@
(defun org-babel-expand-body:sql (body params)
"Expand BODY according to the values of PARAMS."
(org-babel-sql-expand-vars
- body (mapcar #'cdr (org-babel-get-header params :var))))
+ body (org-babel--get-vars params)))
(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."
@@ -90,100 +90,155 @@
(when password (concat "-p" password))
(when database (concat "-D" database))))))
-(defun org-babel-sql-dbstring-postgresql (host user database)
+(defun org-babel-sql-dbstring-postgresql (host port 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 port (format "-p%d" port))
(when user (concat "-U" user))
(when database (concat "-d" database))))))
+(defun org-babel-sql-dbstring-oracle (host port user password database)
+ "Make Oracle command line args for database connection."
+ (format "%s/%s@%s:%s/%s" user password host port database))
+
+(defun org-babel-sql-dbstring-mssql (host user password database)
+ "Make sqlcmd commmand line args for database connection.
+`sqlcmd' is the preferred command line tool to access Microsoft
+SQL Server on Windows and Linux platform."
+ (mapconcat #'identity
+ (delq nil
+ (list (when host (format "-S \"%s\"" host))
+ (when user (format "-U \"%s\"" user))
+ (when password (format "-P \"%s\"" password))
+ (when database (format "-d \"%s\"" database))))
+ " "))
+
+(defun org-babel-sql-convert-standard-filename (file)
+ "Convert the file name to OS standard.
+If in Cygwin environment, uses Cygwin specific function to
+convert the file name. Otherwise, uses Emacs' standard conversion
+function."
+ (format "\"%s\""
+ (if (fboundp 'cygwin-convert-file-name-to-windows)
+ (cygwin-convert-file-name-to-windows file)
+ (convert-standard-filename file))))
+
(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)))
+ (let* ((result-params (cdr (assq :result-params params)))
+ (cmdline (cdr (assq :cmdline params)))
+ (dbhost (cdr (assq :dbhost params)))
(dbport (cdr (assq :dbport params)))
- (dbuser (cdr (assoc :dbuser params)))
- (dbpassword (cdr (assoc :dbpassword params)))
- (database (cdr (assoc :database params)))
- (engine (cdr (assoc :engine params)))
- (colnames-p (not (equal "no" (cdr (assoc :colnames params)))))
+ (dbuser (cdr (assq :dbuser params)))
+ (dbpassword (cdr (assq :dbpassword params)))
+ (database (cdr (assq :database params)))
+ (engine (cdr (assq :engine params)))
+ (colnames-p (not (equal "no" (cdr (assq :colnames params)))))
(in-file (org-babel-temp-file "sql-in-"))
- (out-file (or (cdr (assoc :out-file params))
+ (out-file (or (cdr (assq :out-file params))
(org-babel-temp-file "sql-out-")))
(header-delim "")
- (command (case (intern engine)
- ('dbi (format "dbish --batch %s < %s | sed '%s' > %s"
+ (command (pcase (intern engine)
+ (`dbi (format "dbish --batch %s < %s | sed '%s' > %s"
(or cmdline "")
(org-babel-process-file-name in-file)
"/^+/d;s/^|//;s/(NULL)/ /g;$d"
(org-babel-process-file-name out-file)))
- ('monetdb (format "mclient -f tab %s < %s > %s"
- (or cmdline "")
- (org-babel-process-file-name in-file)
- (org-babel-process-file-name out-file)))
- ('msosql (format "osql %s -s \"\t\" -i %s -o %s"
- (or cmdline "")
- (org-babel-process-file-name in-file)
- (org-babel-process-file-name out-file)))
- ('mysql (format "mysql %s %s %s < %s > %s"
+ (`monetdb (format "mclient -f tab %s < %s > %s"
+ (or cmdline "")
+ (org-babel-process-file-name in-file)
+ (org-babel-process-file-name out-file)))
+ (`mssql (format "sqlcmd %s -s \"\t\" %s -i %s -o %s"
+ (or cmdline "")
+ (org-babel-sql-dbstring-mssql
+ dbhost dbuser dbpassword database)
+ (org-babel-sql-convert-standard-filename
+ (org-babel-process-file-name in-file))
+ (org-babel-sql-convert-standard-filename
+ (org-babel-process-file-name out-file))))
+ (`mysql (format "mysql %s %s %s < %s > %s"
(org-babel-sql-dbstring-mysql
dbhost dbport dbuser dbpassword database)
(if colnames-p "" "-N")
- (or cmdline "")
+ (or cmdline "")
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)))
- ('postgresql (format
- "psql --set=\"ON_ERROR_STOP=1\" %s -A -P footer=off -F \"\t\" %s -f %s -o %s %s"
+ (`postgresql (format
+ "%spsql --set=\"ON_ERROR_STOP=1\" %s -A -P \
+footer=off -F \"\t\" %s -f %s -o %s %s"
+ (if dbpassword
+ (format "PGPASSWORD=%s " dbpassword)
+ "")
(if colnames-p "" "-t")
- (org-babel-sql-dbstring-postgresql dbhost dbuser database)
+ (org-babel-sql-dbstring-postgresql
+ dbhost dbport dbuser database)
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)
(or cmdline "")))
- (t (error "No support for the %s SQL engine" engine)))))
+ (`oracle (format
+ "sqlplus -s %s < %s > %s"
+ (org-babel-sql-dbstring-oracle
+ dbhost dbport dbuser dbpassword database)
+ (org-babel-process-file-name in-file)
+ (org-babel-process-file-name out-file)))
+ (_ (error "No support for the %s SQL engine" engine)))))
(with-temp-file in-file
(insert
- (case (intern engine)
- ('dbi "/format partbox\n")
- (t ""))
+ (pcase (intern engine)
+ (`dbi "/format partbox\n")
+ (`oracle "SET PAGESIZE 50000
+SET NEWPAGE 0
+SET TAB OFF
+SET SPACE 0
+SET LINESIZE 9999
+SET ECHO OFF
+SET FEEDBACK OFF
+SET VERIFY OFF
+SET HEADING ON
+SET MARKUP HTML OFF SPOOL OFF
+SET COLSEP '|'
+
+")
+ (`mssql "SET NOCOUNT ON
+
+")
+ (_ ""))
(org-babel-expand-body:sql body params)))
- (message command)
(org-babel-eval command "")
(org-babel-result-cond result-params
(with-temp-buffer
- (progn (insert-file-contents-literally out-file) (buffer-string)))
+ (progn (insert-file-contents-literally out-file) (buffer-string)))
(with-temp-buffer
(cond
- ((or (eq (intern engine) 'mysql)
- (eq (intern engine) 'dbi)
- (eq (intern engine) 'postgresql))
- ;; Add header row delimiter after column-names header in first line
- (cond
- (colnames-p
- (with-temp-buffer
- (insert-file-contents out-file)
- (goto-char (point-min))
- (forward-line 1)
- (insert "-\n")
- (setq header-delim "-")
- (write-file out-file)))))
- (t
- ;; Need to figure out the delimiter for the header row
- (with-temp-buffer
- (insert-file-contents out-file)
- (goto-char (point-min))
- (when (re-search-forward "^\\(-+\\)[^-]" nil t)
- (setq header-delim (match-string-no-properties 1)))
- (goto-char (point-max))
- (forward-char -1)
- (while (looking-at "\n")
- (delete-char 1)
- (goto-char (point-max))
- (forward-char -1))
- (write-file out-file))))
+ ((memq (intern engine) '(dbi mysql postgresql))
+ ;; Add header row delimiter after column-names header in first line
+ (cond
+ (colnames-p
+ (with-temp-buffer
+ (insert-file-contents out-file)
+ (goto-char (point-min))
+ (forward-line 1)
+ (insert "-\n")
+ (setq header-delim "-")
+ (write-file out-file)))))
+ (t
+ ;; Need to figure out the delimiter for the header row
+ (with-temp-buffer
+ (insert-file-contents out-file)
+ (goto-char (point-min))
+ (when (re-search-forward "^\\(-+\\)[^-]" nil t)
+ (setq header-delim (match-string-no-properties 1)))
+ (goto-char (point-max))
+ (forward-char -1)
+ (while (looking-at "\n")
+ (delete-char 1)
+ (goto-char (point-max))
+ (forward-char -1))
+ (write-file out-file))))
(org-table-import out-file '(16))
(org-babel-reassemble-table
(mapcar (lambda (x)
@@ -191,10 +246,10 @@ This function is called by `org-babel-execute-src-block'."
'hline
x))
(org-table-to-lisp))
- (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))))))))
+ (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))))))))
(defun org-babel-sql-expand-vars (body vars)
"Expand the variables held in VARS in BODY."
@@ -217,7 +272,7 @@ This function is called by `org-babel-execute-src-block'."
vars)
body)
-(defun org-babel-prep-session:sql (session params)
+(defun org-babel-prep-session:sql (_session _params)
"Raise an error because Sql sessions aren't implemented."
(error "SQL sessions not yet implemented"))
diff --git a/lisp/ob-sqlite.el b/lisp/ob-sqlite.el
index 705d7ce..0d954a4 100644
--- a/lisp/ob-sqlite.el
+++ b/lisp/ob-sqlite.el
@@ -1,4 +1,4 @@
-;;; ob-sqlite.el --- org-babel functions for sqlite database interaction
+;;; ob-sqlite.el --- Babel Functions for SQLite Databases -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -53,23 +53,22 @@
(defun org-babel-expand-body:sqlite (body params)
"Expand BODY according to the values of PARAMS."
(org-babel-sqlite-expand-vars
- body (mapcar #'cdr (org-babel-get-header params :var))))
+ body (org-babel--get-vars params)))
(defvar org-babel-sqlite3-command "sqlite3")
(defun org-babel-execute:sqlite (body params)
"Execute a block of Sqlite code with Babel.
This function is called by `org-babel-execute-src-block'."
- (let ((result-params (split-string (or (cdr (assoc :results params)) "")))
- (db (cdr (assoc :db params)))
- (separator (cdr (assoc :separator params)))
- (nullvalue (cdr (assoc :nullvalue params)))
- (headers-p (equal "yes" (cdr (assoc :colnames params))))
+ (let ((result-params (split-string (or (cdr (assq :results params)) "")))
+ (db (cdr (assq :db params)))
+ (separator (cdr (assq :separator params)))
+ (nullvalue (cdr (assq :nullvalue params)))
+ (headers-p (equal "yes" (cdr (assq :colnames params))))
(others (delq nil (mapcar
- (lambda (arg) (car (assoc arg params)))
+ (lambda (arg) (car (assq arg params)))
(list :header :echo :bail :column
- :csv :html :line :list))))
- exit-code)
+ :csv :html :line :list)))))
(unless db (error "ob-sqlite: can't evaluate without a database"))
(with-temp-buffer
(insert
@@ -140,7 +139,7 @@ This function is called by `org-babel-execute-src-block'."
(equal 1 (length (car result))))
(org-babel-read (caar result))
(mapcar (lambda (row)
- (if (equal 'hline row)
+ (if (eq 'hline row)
'hline
(mapcar #'org-babel-string-read row))) result)))
@@ -150,7 +149,7 @@ This function is called by `org-babel-execute-src-block'."
(cons (car table) (cons 'hline (cdr table)))
table))
-(defun org-babel-prep-session:sqlite (session params)
+(defun org-babel-prep-session:sqlite (_session _params)
"Raise an error because support for SQLite sessions isn't implemented.
Prepare SESSION according to the header arguments specified in PARAMS."
(error "SQLite sessions not yet implemented"))
diff --git a/lisp/ob-stan.el b/lisp/ob-stan.el
index e69de29..bf4e394 100644
--- a/lisp/ob-stan.el
+++ b/lisp/ob-stan.el
@@ -0,0 +1,84 @@
+;;; ob-stan.el --- Babel Functions for Stan -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Kyle Meyer
+;; 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 Stan [1] source code.
+;;
+;; Evaluating a Stan block can produce two different results.
+;;
+;; 1) Dump the source code contents to a file.
+;;
+;; This file can then be used as a variable in other blocks, which
+;; allows interfaces like RStan to use the model.
+;;
+;; 2) Compile the contents to a model file.
+;;
+;; This provides access to the CmdStan interface. To use this, set
+;; `org-babel-stan-cmdstan-directory' and provide a :file argument
+;; that does not end in ".stan".
+;;
+;; For more information and usage examples, visit
+;; http://orgmode.org/worg/org-contrib/babel/languages/ob-doc-stan.html
+;;
+;; [1] http://mc-stan.org/
+
+;;; Code:
+(require 'ob)
+(require 'org-compat)
+
+(defcustom org-babel-stan-cmdstan-directory nil
+ "CmdStan source directory.
+'make' will be called from this directory to compile the Stan
+block. When nil, executing Stan blocks dumps the content to a
+plain text file."
+ :group 'org-babel
+ :type 'string)
+
+(defvar org-babel-default-header-args:stan
+ '((:results . "file")))
+
+(defun org-babel-execute:stan (body params)
+ "Generate Stan file from BODY according to PARAMS.
+A :file header argument must be given. If
+`org-babel-stan-cmdstan-directory' is non-nil and the file name
+does not have a \".stan\" extension, save an intermediate
+\".stan\" file and compile the block to the named file.
+Otherwise, write the Stan code directly to the named file."
+ (let ((file (expand-file-name
+ (or (cdr (assq :file params))
+ (user-error "Set :file argument to execute Stan blocks")))))
+ (if (or (not org-babel-stan-cmdstan-directory)
+ (string-match-p "\\.stan\\'" file))
+ (with-temp-file file (insert body))
+ (with-temp-file (concat file ".stan") (insert body))
+ (let ((default-directory org-babel-stan-cmdstan-directory))
+ (call-process-shell-command (concat "make " file))))
+ nil)) ; Signal that output has been written to file.
+
+(defun org-babel-prep-session:stan (_session _params)
+ "Return an error because Stan does not support sessions."
+ (user-error "Stan does not support sessions"))
+
+(provide 'ob-stan)
+;;; ob-stan.el ends here
diff --git a/lisp/ob-table.el b/lisp/ob-table.el
index 6e6d7ac..efee5b7 100644
--- a/lisp/ob-table.el
+++ b/lisp/ob-table.el
@@ -1,4 +1,4 @@
-;;; ob-table.el --- support for calling org-babel functions from tables
+;;; ob-table.el --- Support for Calling Babel Functions from Tables -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -23,8 +23,8 @@
;;; Commentary:
-;; Should allow calling functions from org-mode tables using the
-;; function `org-sbe' as so...
+;; Should allow calling functions from Org tables using the function
+;; `org-sbe' as so...
;; #+begin_src emacs-lisp :results silent
;; (defun fibbd (n) (if (< n 2) 1 (+ (fibbd (- n 1)) (fibbd (- n 2)))))
@@ -55,13 +55,15 @@
;;; Code:
(require 'ob-core)
+(declare-function org-trim "org" (s &optional keep-lead))
+
(defun org-babel-table-truncate-at-newline (string)
"Replace newline character with ellipses.
If STRING ends in a newline character, then remove the newline
character and replace it with ellipses."
(if (and (stringp string) (string-match "[\n\r]\\(.\\)?" string))
(concat (substring string 0 (match-beginning 0))
- (if (match-string 1 string) "...")) string))
+ (when (match-string 1 string) "...")) string))
(defmacro org-sbe (source-block &rest variables)
"Return the results of calling SOURCE-BLOCK with VARIABLES.
@@ -142,7 +144,7 @@ as shown in the example below.
nil (list "emacs-lisp" "results" params)
'((:results . "silent"))))
"")))
- (org-babel-trim (if (stringp result) result (format "%S" result)))))))
+ (org-trim (if (stringp result) result (format "%S" result)))))))
(provide 'ob-table)
diff --git a/lisp/ob-tangle.el b/lisp/ob-tangle.el
index a42dd1d..5e1b953 100644
--- a/lisp/ob-tangle.el
+++ b/lisp/ob-tangle.el
@@ -1,4 +1,4 @@
-;;; ob-tangle.el --- extract source code from org-mode files
+;;; ob-tangle.el --- Extract Source Code From Org Files -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
@@ -26,12 +26,14 @@
;; Extract the code from source blocks out into raw source-code files.
;;; Code:
+
+(require 'cl-lib)
(require 'org-src)
(declare-function make-directory "files" (dir &optional parents))
(declare-function org-at-heading-p "org" (&optional ignored))
-(declare-function org-babel-update-block-body "org" (new-body))
-(declare-function org-back-to-heading "org" (invisible-ok))
+(declare-function org-babel-update-block-body "ob-core" (new-body))
+(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-before-first-heading-p "org" ())
(declare-function org-edit-special "org" (&optional arg))
(declare-function org-element-at-point "org-element" ())
@@ -39,11 +41,14 @@
(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-link-escape "org" (text &optional table merge))
(declare-function org-open-link-from-string "org" (s &optional arg reference-buffer))
+(declare-function org-remove-indentation "org" (code &optional n))
(declare-function org-store-link "org" (arg))
-(declare-function org-string-nw-p "org" (s))
+(declare-function org-string-nw-p "org-macs" (s))
+(declare-function org-trim "org" (s &optional keep-lead))
(declare-function outline-previous-heading "outline" ())
+(declare-function org-id-find "org-id" (id &optional markerp))
(defvar org-link-types-re)
@@ -63,7 +68,7 @@ then the name of the language is used."
(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."
+ "Use relative path names in links from tangled source back the Org file."
:group 'org-babel-tangle
:type 'boolean)
@@ -91,7 +96,7 @@ The following format strings can be used to insert special
information into the output using `org-fill-template'.
%start-line --- the line number at the start of the code block
%file --------- the file from which the code block was tangled
-%link --------- Org-mode style link to the code block
+%link --------- Org style link to the code block
%source-name -- name of the code block
Upon insertion the formatted comment will be commented out, and
@@ -111,7 +116,7 @@ The following format strings can be used to insert special
information into the output using `org-fill-template'.
%start-line --- the line number at the start of the code block
%file --------- the file from which the code block was tangled
-%link --------- Org-mode style link to the code block
+%link --------- Org style link to the code block
%source-name -- name of the code block
Upon insertion the formatted comment will be commented out, and
@@ -133,8 +138,8 @@ 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
+(defcustom org-babel-process-comment-text 'org-remove-indentation
+ "Function called to process raw Org 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-remove-indentation'."
@@ -223,7 +228,7 @@ used to limit the exported source code blocks by language."
org-babel-default-header-args))
(tangle-file
(when (equal arg '(16))
- (or (cdr (assoc :tangle (nth 2 (org-babel-get-src-block-info 'light))))
+ (or (cdr (assq :tangle (nth 2 (org-babel-get-src-block-info 'light))))
(user-error "Point is not in a source code block"))))
path-collector)
(mapc ;; map over all languages
@@ -276,11 +281,11 @@ used to limit the exported source code blocks by language."
;; We avoid append-to-file as it does not work with tramp.
(let ((content (buffer-string)))
(with-temp-buffer
- (if (file-exists-p file-name)
- (insert-file-contents file-name))
+ (when (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))))
+ (unless (or (string= "no" (cdr (assq :padline (nth 4 spec))))
(= (point) (point-min)))
(insert "\n"))
(insert content)
@@ -290,10 +295,8 @@ used to limit the exported source code blocks by language."
(unless tangle-mode (setq tangle-mode #o755)))
;; update counter
(setq block-counter (+ 1 block-counter))
- (add-to-list 'path-collector
- (cons file-name tangle-mode)
- nil
- (lambda (a b) (equal (car a) (car b))))))))
+ (unless (assoc file-name path-collector)
+ (push (cons file-name tangle-mode) path-collector))))))
specs)))
(if (equal arg '(4))
(org-babel-tangle-single-block 1 t)
@@ -321,7 +324,7 @@ used to limit the exported source code blocks by language."
Call this function inside of a source-code file generated by
`org-babel-tangle' to remove all comments inserted automatically
by `org-babel-tangle'. Warning, this comment removes any lines
-containing constructs which resemble org-mode file links or noweb
+containing constructs which resemble Org file links or noweb
references."
(interactive)
(goto-char (point-min))
@@ -362,11 +365,10 @@ that the appropriate major-mode is set. SPEC has the form:
(comments (cdr (assq :comments info)))
(link-p (or (string= comments "both") (string= comments "link")
(string= comments "yes") (string= comments "noweb")))
- (link-data (mapcar (lambda (el)
- (cons (symbol-name el)
- (let ((le (eval el)))
- (if (stringp le) le (format "%S" le)))))
- '(start-line file link source-name)))
+ (link-data `(("start-line" . ,(number-to-string start-line))
+ ("file" . ,file)
+ ("link" . ,link)
+ ("source-name" . ,source-name)))
(insert-comment (lambda (text)
(when (and comments
(not (string= comments "no"))
@@ -390,10 +392,10 @@ that the appropriate major-mode is set. SPEC has the form:
insert-comment
(org-fill-template org-babel-tangle-comment-format-beg link-data)))
(insert
- (format
- "%s\n"
- (org-unescape-code-in-string
- (org-babel-trim body (if org-src-preserve-indentation "[\f\n\r\v]")))))
+ (org-unescape-code-in-string
+ (if org-src-preserve-indentation (org-trim body t)
+ (org-trim (org-remove-indentation body))))
+ "\n")
(when link-p
(funcall
insert-comment
@@ -411,7 +413,7 @@ can be used to limit the collected code blocks by target file."
(let ((current-heading-pos
(org-with-wide-buffer
(org-with-limited-levels (outline-previous-heading)))))
- (if (eq last-heading-pos current-heading-pos) (incf counter)
+ (if (eq last-heading-pos current-heading-pos) (cl-incf counter)
(setq counter 1)
(setq last-heading-pos current-heading-pos)))
(unless (org-in-commented-heading-p)
@@ -453,11 +455,11 @@ list to be used by `org-babel-tangle' directly."
(and (string-match org-bracket-link-regexp link)
(match-string 1 link))))
(source-name
- (intern (or (nth 4 info)
- (format "%s:%d"
- (or (ignore-errors (nth 4 (org-heading-components)))
- "No heading")
- block-counter))))
+ (or (nth 4 info)
+ (format "%s:%d"
+ (or (ignore-errors (nth 4 (org-heading-components)))
+ "No heading")
+ block-counter)))
(expand-cmd
(intern (concat "org-babel-expand-body:" src-lang)))
(assignments-cmd
@@ -469,7 +471,7 @@ list to be used by `org-babel-tangle' directly."
(org-babel-expand-noweb-references info)
(nth 1 info)))
(body
- (if (assoc :no-expand params)
+ (if (assq :no-expand params)
body
(if (fboundp expand-cmd)
(funcall expand-cmd body params)
@@ -487,8 +489,8 @@ list to be used by `org-babel-tangle' directly."
(run-hooks 'org-babel-tangle-body-hook)
(buffer-string))))
(comment
- (when (or (string= "both" (cdr (assoc :comments params)))
- (string= "org" (cdr (assoc :comments params))))
+ (when (or (string= "both" (cdr (assq :comments params)))
+ (string= "org" (cdr (assq :comments params))))
;; From the previous heading or code-block end
(funcall
org-babel-process-comment-text
@@ -510,26 +512,25 @@ list to be used by `org-babel-tangle' directly."
(list (cons src-lang (list result)))
result)))
-(defun org-babel-tangle-comment-links ( &optional info)
+(defun org-babel-tangle-comment-links (&optional info)
"Return a list of begin and end link comments for the code block at point."
- (let* ((start-line (org-babel-where-is-src-block-head))
- (file (buffer-file-name))
- (link (org-link-escape (progn (call-interactively 'org-store-link)
- (org-no-properties
- (car (pop org-stored-links))))))
- (source-name (nth 4 (or info (org-babel-get-src-block-info 'light))))
- (link-data (mapcar (lambda (el)
- (cons (symbol-name el)
- (let ((le (eval el)))
- (if (stringp le) le (format "%S" le)))))
- '(start-line file link source-name))))
+ (let ((link-data
+ `(("start-line" . ,(number-to-string
+ (org-babel-where-is-src-block-head)))
+ ("file" . ,(buffer-file-name))
+ ("link" . ,(org-link-escape
+ (progn
+ (call-interactively #'org-store-link)
+ (org-no-properties (car (pop org-stored-links))))))
+ ("source-name" .
+ ,(nth 4 (or info (org-babel-get-src-block-info 'light)))))))
(list (org-fill-template org-babel-tangle-comment-format-beg link-data)
(org-fill-template org-babel-tangle-comment-format-end link-data))))
;; de-tangling functions
(defvar org-bracket-link-analytic-regexp)
(defun org-babel-detangle (&optional source-code-file)
- "Propagate changes in source file back original to Org-mode file.
+ "Propagate changes in source file back original to Org file.
This requires that code blocks were tangled with link comments
which enable the original code blocks to be found."
(interactive)
@@ -553,7 +554,7 @@ which enable the original code blocks to be found."
"Jump from a tangled code file to the related Org mode file."
(interactive)
(let ((mid (point))
- start body-start end done
+ start body-start end
target-buffer target-char link path block-name body)
(save-window-excursion
(save-excursion
@@ -575,7 +576,7 @@ which enable the original code blocks to be found."
(setq body (buffer-substring body-start end)))
(when (string-match "::" path)
(setq path (substring path 0 (match-beginning 0))))
- (find-file path)
+ (find-file (or (car (org-id-find path)) path))
(setq target-buffer (current-buffer))
;; Go to the beginning of the relative block in Org file.
(org-open-link-from-string link)
@@ -598,7 +599,8 @@ which enable the original code blocks to be found."
(forward-char (- mid body-start))
(setq target-char (point)))
(org-src-switch-to-buffer target-buffer t)
- (prog1 body (goto-char target-char))))
+ (goto-char target-char)
+ body))
(provide 'ob-tangle)
diff --git a/lisp/ob.el b/lisp/ob.el
index cc46693..491b0d7 100644
--- a/lisp/ob.el
+++ b/lisp/ob.el
@@ -1,4 +1,4 @@
-;;; ob.el --- working with code blocks in org-mode
+;;; ob.el --- Working with Code Blocks in Org -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 19a4095..7ee721a 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -24,7 +24,7 @@
;;
;;; Commentary:
-;; This file contains the code for creating and using the Agenda for Org-mode.
+;; This file contains the code for creating and using the Agenda for Org.
;;
;; The functions `org-batch-agenda', `org-batch-agenda-csv', and
;; `org-batch-store-agenda-views' are implemented as macros to provide
@@ -45,10 +45,9 @@
;;; Code:
+(require 'cl-lib)
(require 'org)
(require 'org-macs)
-(eval-when-compile
- (require 'cl))
(declare-function diary-add-to-list "diary-lib"
(date string specifier &optional marker globcolor literal))
@@ -80,16 +79,15 @@
(declare-function org-is-habit-p "org-habit" (&optional pom))
(declare-function org-habit-parse-todo "org-habit" (&optional pom))
(declare-function org-habit-get-priority "org-habit" (habit &optional moment))
-(declare-function org-pop-to-buffer-same-window "org-compat"
- (&optional buffer-or-name norecord label))
(declare-function org-agenda-columns "org-colview" ())
(declare-function org-add-archive-files "org-archive" (files))
(declare-function org-capture "org-capture" (&optional goto keys))
-(defvar calendar-mode-map) ; defined in calendar.el
-(defvar org-clock-current-task nil) ; defined in org-clock.el
-(defvar org-mobile-force-id-on-agenda-items) ; defined in org-mobile.el
-(defvar org-habit-show-habits) ; defined in org-habit.el
+(defvar calendar-mode-map)
+(defvar org-clock-current-task)
+(defvar org-current-tag-alist)
+(defvar org-mobile-force-id-on-agenda-items)
+(defvar org-habit-show-habits)
(defvar org-habit-show-habits-only-for-today)
(defvar org-habit-show-all-today)
@@ -97,8 +95,8 @@
(defvar org-agenda-buffer-name "*Org Agenda*")
(defvar org-agenda-overriding-header nil)
(defvar org-agenda-title-append nil)
-(org-no-warnings (defvar entry)) ;; unprefixed, from calendar.el
-(org-no-warnings (defvar date)) ;; unprefixed, from calendar.el
+(with-no-warnings (defvar entry)) ;; unprefixed, from calendar.el
+(with-no-warnings (defvar date)) ;; unprefixed, from calendar.el
(defvar original-date) ; dynamically scoped, calendar.el does scope this
(defvar org-agenda-undo-list nil
@@ -136,7 +134,7 @@ addresses the separator between the current and the previous block."
(string)))
(defgroup org-agenda-export nil
- "Options concerning exporting agenda views in Org-mode."
+ "Options concerning exporting agenda views in Org mode."
:tag "Org Agenda Export"
:group 'org-agenda)
@@ -238,7 +236,7 @@ you can \"misuse\" it to also add other text to the header."
:type 'boolean)
(defgroup org-agenda-custom-commands nil
- "Options concerning agenda views in Org-mode."
+ "Options concerning agenda views in Org mode."
:tag "Org Agenda Custom Commands"
:group 'org-agenda)
@@ -262,8 +260,8 @@ you can \"misuse\" it to also add other text to the header."
;; Keep custom values for `org-agenda-filter-preset' compatible with
;; the new variable `org-agenda-tag-filter-preset'.
-(org-defvaralias 'org-agenda-filter-preset 'org-agenda-tag-filter-preset)
-(org-defvaralias 'org-agenda-filter 'org-agenda-tag-filter)
+(defvaralias 'org-agenda-filter-preset 'org-agenda-tag-filter-preset)
+(defvaralias 'org-agenda-filter 'org-agenda-tag-filter)
(defvar org-agenda-entry-types '(:deadline :scheduled :timestamp :sexp)
"List of types searched for when creating the daily/weekly agenda.
@@ -442,8 +440,9 @@ This will be spliced into the custom type of
(defcustom org-agenda-custom-commands
'(("n" "Agenda and all TODOs" ((agenda "") (alltodo ""))))
"Custom commands for the agenda.
+\\<org-mode-map>
These commands will be offered on the splash screen displayed by the
-agenda dispatcher \\[org-agenda]. Each entry is a list like this:
+agenda dispatcher `\\[org-agenda]'. Each entry is a list like this:
(key desc type match settings files)
@@ -608,14 +607,17 @@ subtree to see if any of the subtasks have project status.
See also the variable `org-tags-match-list-sublevels' which applies
to projects matched by this search as well.
-After defining this variable, you may use \\[org-agenda-list-stuck-projects]
-or `C-c a #' to produce the list."
+After defining this variable, you may use `\\[org-agenda-list-stuck-projects]'
+\(bound to `C-c a #') to produce the list."
:group 'org-agenda-custom-commands
:type '(list
(string :tag "Tags/TODO match to identify a project")
- (repeat :tag "Projects are *not* stuck if they have an entry with TODO keyword any of" (string))
- (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")))
+ (repeat :tag "Projects are *not* stuck if they have an entry with \
+TODO keyword any of" (string))
+ (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")))
(defgroup org-agenda-skip nil
"Options concerning skipping parts of agenda files."
@@ -999,8 +1001,6 @@ you want to use two-columns display (see `org-agenda-menu-two-columns')."
:version "24.1"
:type 'boolean)
-(define-obsolete-variable-alias 'org-agenda-menu-two-column 'org-agenda-menu-two-columns "24.3")
-
(defcustom org-agenda-menu-two-columns nil
"Non-nil means, use two columns to show custom commands in the dispatcher.
If you use this, you probably want to set `org-agenda-menu-show-matcher'
@@ -1009,7 +1009,6 @@ to nil."
:version "24.1"
:type 'boolean)
-(define-obsolete-variable-alias 'org-finalize-agenda-hook 'org-agenda-finalize-hook "24.3")
(defcustom org-agenda-finalize-hook nil
"Hook run just before displaying an agenda buffer.
The buffer is still writable when the hook is called.
@@ -1022,8 +1021,8 @@ headlines as the agenda display heavily relies on them."
(defcustom org-agenda-mouse-1-follows-link nil
"Non-nil means mouse-1 on a link will follow the link in the agenda.
-A longer mouse click will still set point. Does not work on XEmacs.
-Needs to be set before org.el is loaded."
+A longer mouse click will still set point. Needs to be set
+before org.el is loaded."
:group 'org-agenda-startup
:type 'boolean)
@@ -1052,9 +1051,9 @@ current item's tree, in an indirect buffer."
(defcustom org-agenda-entry-text-maxlines 5
"Number of text lines to be added when `E' is pressed in the agenda.
-Note that this variable only used during agenda display. Add add entry text
+Note that this variable only used during agenda display. To add entry text
when exporting the agenda, configure the variable
-`org-agenda-add-entry-ext-maxlines'."
+`org-agenda-add-entry-text-maxlines'."
:group 'org-agenda
:type 'integer)
@@ -1126,16 +1125,6 @@ option will be ignored."
:group 'org-agenda-windows
:type 'boolean)
-(defcustom org-agenda-ndays nil
- "Number of days to include in overview display.
-Should be 1 or 7.
-Obsolete, see `org-agenda-span'."
- :group 'org-agenda-daily/weekly
- :type '(choice (const nil)
- (integer)))
-
-(make-obsolete-variable 'org-agenda-ndays 'org-agenda-span "24.1")
-
(defcustom org-agenda-span 'week
"Number of days to include in overview display.
Can be day, week, month, year, or any number of days.
@@ -1284,9 +1273,9 @@ shown, either today or the nearest into the future."
(defcustom org-scheduled-past-days 10000
"Number of days to continue listing scheduled items not marked DONE.
-When an item is scheduled on a date, it shows up in the agenda on this
-day and will be listed until it is marked done for the number of days
-given here."
+When an item is scheduled on a date, it shows up in the agenda on
+this day and will be listed until it is marked done or for the
+number of days given here."
:group 'org-agenda-daily/weekly
:type 'integer)
@@ -1415,7 +1404,7 @@ boolean search."
:version "24.1"
:type 'boolean)
-(org-defvaralias 'org-agenda-search-view-search-words-only
+(defvaralias 'org-agenda-search-view-search-words-only
'org-agenda-search-view-always-boolean)
(defcustom org-agenda-search-view-force-full-words nil
@@ -1436,7 +1425,7 @@ value, don't limit agenda view by outline level."
:type 'integer)
(defgroup org-agenda-time-grid nil
- "Options concerning the time grid in the Org-mode Agenda."
+ "Options concerning the time grid in the Org Agenda."
:tag "Org Agenda Time Grid"
:group 'org-agenda)
@@ -1508,7 +1497,7 @@ a grid line."
:type 'string)
(defgroup org-agenda-sorting nil
- "Options concerning sorting in the Org-mode Agenda."
+ "Options concerning sorting in the Org Agenda."
:tag "Org Agenda Sorting"
:group 'org-agenda)
@@ -1614,7 +1603,7 @@ When nil, such items are sorted as 0 minutes effort."
:type 'boolean)
(defgroup org-agenda-line-format nil
- "Options concerning the entry prefix in the Org-mode agenda display."
+ "Options concerning the entry prefix in the Org agenda display."
:tag "Org Agenda Line Format"
:group 'org-agenda)
@@ -1860,10 +1849,10 @@ When this is the symbol `prefix', only remove tags when
(const :tag "Never" nil)
(const :tag "When prefix format contains %T" prefix)))
-(org-defvaralias 'org-agenda-remove-tags-when-in-prefix
+(defvaralias 'org-agenda-remove-tags-when-in-prefix
'org-agenda-remove-tags)
-(defcustom org-agenda-tags-column (if (featurep 'xemacs) -79 -80)
+(defcustom org-agenda-tags-column -80
"Shift tags in agenda items to this column.
If this number is positive, it specifies the column. If it is negative,
it means that the tags should be flushright to that column. For example,
@@ -1871,7 +1860,7 @@ it means that the tags should be flushright to that column. For example,
:group 'org-agenda-line-format
:type 'integer)
-(org-defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column)
+(defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column)
(defcustom org-agenda-fontify-priorities 'cookies
"Non-nil means highlight low and high priorities in agenda.
@@ -1950,6 +1939,14 @@ category, you can use:
:tag "Org Agenda Column View"
:group 'org-agenda)
+(defcustom org-agenda-view-columns-initially nil
+ "When non-nil, switch to columns view right after creating the agenda."
+ :group 'org-agenda-column-view
+ :type 'boolean
+ :version "25.2"
+ :package-version '(Org . "9.0")
+ :safe #'booleanp)
+
(defcustom org-agenda-columns-show-summaries t
"Non-nil means show summaries for columns displayed in the agenda view."
:group 'org-agenda-column-view
@@ -1999,7 +1996,7 @@ For example, this value makes those two functions available:
With selected entries in an agenda buffer, `B R' will call
the custom function `set-category' on the selected entries.
Note that functions in this alist don't need to be quoted."
- :type 'alist
+ :type '(alist :key-type character :value-type (group function))
:version "24.1"
:group 'org-agenda)
@@ -2030,7 +2027,7 @@ works you probably want to add it to `org-agenda-custom-commands' for good."
(defvar org-agenda-mode-map (make-sparse-keymap)
"Keymap for `org-agenda-mode'.")
-(org-defvaralias 'org-agenda-keymap 'org-agenda-mode-map)
+(defvaralias 'org-agenda-keymap 'org-agenda-mode-map)
(defvar org-agenda-menu) ; defined later in this file.
(defvar org-agenda-restrict nil) ; defined later in this file.
@@ -2047,6 +2044,8 @@ The buffer is still writable when this hook is called.")
(defvar org-agenda-force-single-file nil)
(defvar org-agenda-bulk-marked-entries nil
"List of markers that refer to marked entries in the agenda.")
+(defvar org-agenda-current-date nil
+ "Active date when building the agenda.")
;;; Multiple agenda buffers support
@@ -2067,12 +2066,12 @@ When nil, `q' will kill the single agenda buffer."
(> (prefix-numeric-value arg) 0)
(not org-agenda-sticky))))
(if (equal new-value org-agenda-sticky)
- (and (org-called-interactively-p 'interactive)
+ (and (called-interactively-p 'interactive)
(message "Sticky agenda was already %s"
(if org-agenda-sticky "enabled" "disabled")))
(setq org-agenda-sticky new-value)
(org-agenda-kill-all-agenda-buffers)
- (and (org-called-interactively-p 'interactive)
+ (and (called-interactively-p 'interactive)
(message "Sticky agenda %s"
(if org-agenda-sticky "enabled" "disabled"))))))
@@ -2117,7 +2116,7 @@ When nil, `q' will kill the single agenda buffer."
"Variables that must be local in agenda buffers to allow multiple buffers.")
(defun org-agenda-mode ()
- "Mode for time-sorted view on action items in Org-mode files.
+ "Mode for time-sorted view on action items in Org files.
The following commands are available:
@@ -2137,32 +2136,32 @@ The following commands are available:
(when (and val
(member var org-agenda-local-vars))
(set var val)))))
- (set (make-local-variable 'org-agenda-this-buffer-is-sticky) t))
+ (setq-local org-agenda-this-buffer-is-sticky t))
(org-agenda-sticky
;; Creating a sticky Agenda buffer for the first time
(kill-all-local-variables)
(mapc 'make-local-variable org-agenda-local-vars)
- (set (make-local-variable 'org-agenda-this-buffer-is-sticky) t))
+ (setq-local org-agenda-this-buffer-is-sticky t))
(t
;; Creating a non-sticky agenda buffer
(kill-all-local-variables)
- (set (make-local-variable 'org-agenda-this-buffer-is-sticky) nil)))
+ (setq-local org-agenda-this-buffer-is-sticky nil)))
(setq org-agenda-undo-list nil
org-agenda-pending-undo-list nil
org-agenda-bulk-marked-entries nil)
(setq major-mode 'org-agenda-mode)
;; Keep global-font-lock-mode from turning on font-lock-mode
- (org-set-local 'font-lock-global-modes (list 'not major-mode))
+ (setq-local font-lock-global-modes (list 'not major-mode))
(setq mode-name "Org-Agenda")
(setq indent-tabs-mode nil)
(use-local-map org-agenda-mode-map)
(easy-menu-add org-agenda-menu)
(if org-startup-truncated (setq truncate-lines t))
- (org-set-local 'line-move-visual nil)
- (org-add-hook 'post-command-hook 'org-agenda-update-agenda-type nil 'local)
- (org-add-hook 'pre-command-hook 'org-unhighlight nil 'local)
+ (setq-local line-move-visual nil)
+ (add-hook 'post-command-hook 'org-agenda-update-agenda-type nil 'local)
+ (add-hook 'pre-command-hook 'org-unhighlight nil 'local)
;; Make sure properties are removed when copying text
- (org-add-hook 'filter-buffer-substring-functions
+ (add-hook 'filter-buffer-substring-functions
(lambda (fun start end delete)
(substring-no-properties (funcall fun start end delete)))
nil t)
@@ -2319,7 +2318,6 @@ The following commands are available:
(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)
(org-defkey org-agenda-mode-map "~" 'org-agenda-limit-interactively)
(org-defkey org-agenda-mode-map "<" 'org-agenda-filter-by-category)
(org-defkey org-agenda-mode-map "^" 'org-agenda-filter-by-top-headline)
@@ -2399,7 +2397,7 @@ The following commands are available:
["Remove Restriction" org-agenda-remove-restriction-lock org-agenda-restrict])
["Write view to file" org-agenda-write t]
["Rebuild buffer" org-agenda-redo t]
- ["Save all Org-mode Buffers" org-save-all-org-buffers t]
+ ["Save all Org buffers" org-save-all-org-buffers t]
"--"
["Show original entry" org-agenda-show t]
["Go To (other window)" org-agenda-goto t]
@@ -2668,6 +2666,7 @@ to limit entries to in this type."
(const timeline))
(integer :tag "Max number of minutes")))))
+(defvar org-agenda-keep-restricted-file-list nil)
(defvar org-keys nil)
(defvar org-match nil)
;;;###autoload
@@ -2700,9 +2699,9 @@ More commands can be added by configuring the variable
`org-agenda-custom-commands'. In particular, specific tags and TODO keyword
searches can be pre-defined in this way.
-If the current buffer is in Org-mode and visiting a file, you can also
+If the current buffer is in Org mode and visiting a file, you can also
first press `<' once to indicate that the agenda should be temporarily
-\(until the next use of \\[org-agenda]) restricted to the current file.
+\(until the next use of `\\[org-agenda]') restricted to the current file.
Pressing `<' twice means to restrict to the current subtree or region
\(if active)."
(interactive "P")
@@ -2734,7 +2733,7 @@ Pressing `<' twice means to restrict to the current subtree or region
entry key type org-match lprops ans)
;; Turn off restriction unless there is an overriding one,
(unless org-agenda-overriding-restriction
- (unless (org-bound-and-true-p org-agenda-keep-restricted-file-list)
+ (unless org-agenda-keep-restricted-file-list
;; There is a request to keep the file list in place
(put 'org-agenda-files 'org-restrict nil))
(setq org-agenda-restrict nil)
@@ -2831,7 +2830,7 @@ Pressing `<' twice means to restrict to the current subtree or region
((equal org-keys "M") (org-call-with-arg 'org-tags-view (or arg '(4))))
((equal org-keys "e") (call-interactively 'org-store-agenda-views))
((equal org-keys "?") (org-tags-view nil "+FLAGGED")
- (org-add-hook
+ (add-hook
'post-command-hook
(lambda ()
(unless (current-message)
@@ -2848,7 +2847,7 @@ Pressing `<' twice means to restrict to the current subtree or region
t t))
((equal org-keys "L")
(unless (derived-mode-p 'org-mode)
- (user-error "This is not an Org-mode file"))
+ (user-error "This is not an Org file"))
(unless restriction
(put 'org-agenda-files 'org-restrict (list bfn))
(org-call-with-arg 'org-timeline arg)))
@@ -3046,7 +3045,7 @@ L Timeline for current buffer # List stuck projects (!=configure)
(call-interactively 'org-toggle-sticky-agenda)
(sit-for 2))
((and (not restrict-ok) (memq c '(?1 ?0 ?<)))
- (message "Restriction is only possible in Org-mode buffers")
+ (message "Restriction is only possible in Org buffers")
(ding) (sit-for 1))
((eq c ?1)
(org-agenda-remove-restriction-lock 'noupdate)
@@ -3104,9 +3103,9 @@ L Timeline for current buffer # List stuck projects (!=configure)
match ;; The byte compiler incorrectly complains about this. Keep it!
org-cmd type lprops)
(while (setq org-cmd (pop cmds))
- (setq type (car org-cmd)
- match (eval (nth 1 org-cmd))
- lprops (nth 2 org-cmd))
+ (setq type (car org-cmd))
+ (setq match (eval (nth 1 org-cmd)))
+ (setq lprops (nth 2 org-cmd))
(let ((org-agenda-overriding-arguments
(if (eq org-agenda-overriding-cmd org-cmd)
(or org-agenda-overriding-arguments
@@ -3159,7 +3158,7 @@ Parameters are alternating variable names and values that will be bound
before running the agenda command."
(org-eval-in-environment (org-make-parameter-alist parameters)
(let (org-agenda-sticky)
- (if (> (length cmd-key) 2)
+ (if (> (length cmd-key) 1)
(org-tags-view nil cmd-key)
(org-agenda nil cmd-key))))
(set-buffer org-agenda-buffer-name)
@@ -3260,9 +3259,7 @@ This ensures the export commands can easily use it."
((not res) "")
((stringp res) res)
(t (prin1-to-string res))))
- (while (string-match "," res)
- (setq res (replace-match ";" t t res)))
- (org-trim res)))
+ (org-trim (replace-regexp-in-string "," ";" res nil t))))
;;;###autoload
(defun org-store-agenda-views (&rest parameters)
@@ -3338,13 +3335,15 @@ the agenda to write."
(interactive "FWrite agenda to file: \nP")
(if (or (not (file-writable-p file))
(and (file-exists-p file)
- (if (org-called-interactively-p 'any)
+ (if (called-interactively-p 'any)
(not (y-or-n-p (format "Overwrite existing file %s? " file))))))
(user-error "Cannot write agenda to file %s" file))
(org-let (if nosettings nil org-agenda-exporter-settings)
'(save-excursion
(save-window-excursion
- (let ((bs (copy-sequence (buffer-string))) beg content)
+ (let ((bs (copy-sequence (buffer-string)))
+ (extension (file-name-extension file))
+ beg content)
(with-temp-buffer
(rename-buffer org-agenda-write-buffer-name t)
(set-buffer-modified-p nil)
@@ -3352,9 +3351,9 @@ the agenda to write."
(org-agenda-remove-marked-text 'invisible 'org-filtered)
(run-hooks 'org-agenda-before-write-hook)
(cond
- ((org-bound-and-true-p org-mobile-creating-agendas)
+ ((bound-and-true-p org-mobile-creating-agendas)
(org-mobile-write-agenda-for-mobile file))
- ((string-match "\\.org\\'" file)
+ ((string= "org" extension)
(let (content p m message-log-max)
(goto-char (point-min))
(while (setq p (next-single-property-change (point) 'org-hd-marker nil))
@@ -3373,7 +3372,7 @@ the agenda to write."
(write-file file)
(kill-buffer (current-buffer))
(message "Org file written to %s" file)))
- ((string-match "\\.html?\\'" file)
+ ((member extension '("html" "htm"))
(require 'htmlize)
(set-buffer (htmlize-buffer (current-buffer)))
(when org-agenda-export-html-style
@@ -3385,11 +3384,11 @@ the agenda to write."
(write-file file)
(kill-buffer (current-buffer))
(message "HTML written to %s" file))
- ((string-match "\\.ps\\'" file)
+ ((string= "ps" extension)
(require 'ps-print)
(ps-print-buffer-with-faces file)
(message "Postscript written to %s" file))
- ((string-match "\\.pdf\\'" file)
+ ((string= "pdf" extension)
(require 'ps-print)
(ps-print-buffer-with-faces
(concat (file-name-sans-extension file) ".ps"))
@@ -3399,7 +3398,7 @@ the agenda to write."
(expand-file-name file))
(delete-file (concat (file-name-sans-extension file) ".ps"))
(message "PDF written to %s" file))
- ((string-match "\\.ics\\'" file)
+ ((string= "ics" extension)
(require 'ox-icalendar)
(org-icalendar-export-current-agenda (expand-file-name file)))
(t
@@ -3411,7 +3410,7 @@ the agenda to write."
(kill-buffer (current-buffer))
(message "Plain text written to %s" file))))))))
(set-buffer (or agenda-bufname
- (and (org-called-interactively-p 'any) (buffer-name))
+ (and (called-interactively-p 'any) (buffer-name))
org-agenda-buffer-name)))
(when open (org-open-file file)))
@@ -3432,7 +3431,7 @@ This will add a maximum of `org-agenda-add-entry-text-maxlines' lines of the
entry text following headings shown in the agenda.
Drawers will be excluded, also the line with scheduling/deadline info."
(when (and (> org-agenda-add-entry-text-maxlines 0)
- (not (org-bound-and-true-p org-mobile-creating-agendas)))
+ (not (bound-and-true-p org-mobile-creating-agendas)))
(let (m txt)
(goto-char (point-min))
(while (not (eobp))
@@ -3457,85 +3456,83 @@ removed from the entry content. Currently only `planning' is allowed here."
(with-current-buffer (marker-buffer marker)
(if (not (derived-mode-p 'org-mode))
(setq txt "")
- (save-excursion
- (save-restriction
- (widen)
- (goto-char marker)
- (end-of-line 1)
- (setq txt (buffer-substring
- (min (1+ (point)) (point-max))
- (progn (outline-next-heading) (point)))
- drawer-re org-drawer-regexp
- kwd-time-re (concat "^[ \t]*" org-keyword-time-regexp
- ".*\n?"))
- (with-temp-buffer
- (insert txt)
- (when org-agenda-add-entry-text-descriptive-links
- (goto-char (point-min))
- (while (org-activate-bracket-links (point-max))
- (add-text-properties (match-beginning 0) (match-end 0)
- '(face org-link))))
- (goto-char (point-min))
- (while (re-search-forward org-bracket-link-regexp (point-max) t)
- (set-text-properties (match-beginning 0) (match-end 0)
- nil))
- (goto-char (point-min))
- (while (re-search-forward drawer-re nil t)
- (delete-region
- (match-beginning 0)
- (progn (re-search-forward
- "^[ \t]*:END:.*\n?" nil 'move)
- (point))))
- (unless (member 'planning keep)
- (goto-char (point-min))
- (while (re-search-forward kwd-time-re nil t)
- (replace-match "")))
- (goto-char (point-min))
- (when org-agenda-entry-text-exclude-regexps
- (let ((re-list org-agenda-entry-text-exclude-regexps) re)
- (while (setq re (pop re-list))
- (goto-char (point-min))
- (while (re-search-forward re nil t)
- (replace-match "")))))
- (goto-char (point-max))
- (skip-chars-backward " \t\n")
- (if (looking-at "[ \t\n]+\\'") (replace-match ""))
-
- ;; find and remove min common indentation
- (goto-char (point-min))
- (untabify (point-min) (point-max))
- (setq ind (org-get-indentation))
- (while (not (eobp))
- (unless (looking-at "[ \t]*$")
- (setq ind (min ind (org-get-indentation))))
- (beginning-of-line 2))
- (goto-char (point-min))
- (while (not (eobp))
- (unless (looking-at "[ \t]*$")
- (move-to-column ind)
- (delete-region (point-at-bol) (point)))
- (beginning-of-line 2))
-
- (run-hooks 'org-agenda-entry-text-cleanup-hook)
-
- (goto-char (point-min))
- (when indent
- (while (and (not (eobp)) (re-search-forward "^" nil t))
- (replace-match indent t t)))
- (goto-char (point-min))
- (while (looking-at "[ \t]*\n") (replace-match ""))
- (goto-char (point-max))
- (when (> (org-current-line)
- n-lines)
- (org-goto-line (1+ n-lines))
- (backward-char 1))
- (setq txt (buffer-substring (point-min) (point)))))))))
+ (org-with-wide-buffer
+ (goto-char marker)
+ (end-of-line 1)
+ (setq txt (buffer-substring
+ (min (1+ (point)) (point-max))
+ (progn (outline-next-heading) (point)))
+ drawer-re org-drawer-regexp
+ kwd-time-re (concat "^[ \t]*" org-keyword-time-regexp
+ ".*\n?"))
+ (with-temp-buffer
+ (insert txt)
+ (when org-agenda-add-entry-text-descriptive-links
+ (goto-char (point-min))
+ (while (org-activate-bracket-links (point-max))
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(face org-link))))
+ (goto-char (point-min))
+ (while (re-search-forward org-bracket-link-regexp (point-max) t)
+ (set-text-properties (match-beginning 0) (match-end 0)
+ nil))
+ (goto-char (point-min))
+ (while (re-search-forward drawer-re nil t)
+ (delete-region
+ (match-beginning 0)
+ (progn (re-search-forward
+ "^[ \t]*:END:.*\n?" nil 'move)
+ (point))))
+ (unless (member 'planning keep)
+ (goto-char (point-min))
+ (while (re-search-forward kwd-time-re nil t)
+ (replace-match "")))
+ (goto-char (point-min))
+ (when org-agenda-entry-text-exclude-regexps
+ (let ((re-list org-agenda-entry-text-exclude-regexps) re)
+ (while (setq re (pop re-list))
+ (goto-char (point-min))
+ (while (re-search-forward re nil t)
+ (replace-match "")))))
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (if (looking-at "[ \t\n]+\\'") (replace-match ""))
+
+ ;; find and remove min common indentation
+ (goto-char (point-min))
+ (untabify (point-min) (point-max))
+ (setq ind (org-get-indentation))
+ (while (not (eobp))
+ (unless (looking-at "[ \t]*$")
+ (setq ind (min ind (org-get-indentation))))
+ (beginning-of-line 2))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (unless (looking-at "[ \t]*$")
+ (move-to-column ind)
+ (delete-region (point-at-bol) (point)))
+ (beginning-of-line 2))
+
+ (run-hooks 'org-agenda-entry-text-cleanup-hook)
+
+ (goto-char (point-min))
+ (when indent
+ (while (and (not (eobp)) (re-search-forward "^" nil t))
+ (replace-match indent t t)))
+ (goto-char (point-min))
+ (while (looking-at "[ \t]*\n") (replace-match ""))
+ (goto-char (point-max))
+ (when (> (org-current-line)
+ n-lines)
+ (org-goto-line (1+ n-lines))
+ (backward-char 1))
+ (setq txt (buffer-substring (point-min) (point))))))))
txt))
(defun org-check-for-org-mode ()
"Make sure current buffer is in org-mode. Error if not."
(or (derived-mode-p 'org-mode)
- (error "Cannot execute org-mode agenda command on buffer in %s"
+ (error "Cannot execute Org agenda command on buffer in %s"
major-mode)))
;;; Agenda prepare and finalize
@@ -3620,26 +3617,26 @@ FILTER-ALIST is an alist of filters we need to apply when
((equal (current-buffer) abuf) nil)
(awin (select-window awin))
((not (setq wconf (current-window-configuration))))
- ((equal org-agenda-window-setup 'current-window)
- (org-pop-to-buffer-same-window abuf))
- ((equal org-agenda-window-setup 'other-window)
+ ((eq org-agenda-window-setup 'current-window)
+ (pop-to-buffer-same-window abuf))
+ ((eq org-agenda-window-setup 'other-window)
(org-switch-to-buffer-other-window abuf))
- ((equal org-agenda-window-setup 'other-frame)
+ ((eq 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)
+ (pop-to-buffer-same-window abuf))
+ ((eq 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)))
+ (setq org-agenda-tag-filter (cdr (assq 'tag filter-alist)))
+ (setq org-agenda-category-filter (cdr (assq 'cat filter-alist)))
+ (setq org-agenda-effort-filter (cdr (assq 'effort filter-alist)))
+ (setq org-agenda-regexp-filter (cdr (assq '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))
+ (pop-to-buffer-same-window abuf))
(setq org-agenda-pre-window-conf
(or wconf org-agenda-pre-window-conf))))
@@ -3703,7 +3700,7 @@ FILTER-ALIST is an alist of filters we need to apply when
(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)
- (org-set-local 'org-agenda-name name)))
+ (setq-local org-agenda-name name)))
(setq buffer-read-only nil))))
(defvar org-agenda-overriding-columns-format) ; From org-colview.el
@@ -3727,8 +3724,8 @@ FILTER-ALIST is an alist of filters we need to apply when
(remove-text-properties (point-min) (point-max) '(face nil)))
(if (and (boundp 'org-agenda-overriding-columns-format)
org-agenda-overriding-columns-format)
- (org-set-local 'org-agenda-overriding-columns-format
- org-agenda-overriding-columns-format))
+ (setq-local org-agenda-overriding-columns-format
+ org-agenda-overriding-columns-format))
(if (and (boundp 'org-agenda-view-columns-initially)
org-agenda-view-columns-initially)
(org-agenda-columns))
@@ -3785,13 +3782,13 @@ FILTER-ALIST is an alist of filters we need to apply when
(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)))))
+ (add-hook 'kill-buffer-hook 'org-agenda-reset-markers 'append 'local)))))
(defun org-agenda-mark-clocking-task ()
"Mark the current clock entry in the agenda if it is present."
;; We need to widen when `org-agenda-finalize' is called from
;; `org-agenda-change-all-lines' (e.g. in `org-agenda-clock-in')
- (when org-clock-current-task
+ (when (bound-and-true-p org-clock-current-task)
(save-restriction
(widen)
(org-agenda-unmark-clocking-task)
@@ -3858,7 +3855,7 @@ FILTER-ALIST is an alist of filters we need to apply when
When INVISIBLE is non-nil, hide currently blocked TODO instead of
dimming them."
(interactive "P")
- (when (org-called-interactively-p 'interactive)
+ (when (called-interactively-p 'interactive)
(message "Dim or hide blocked tasks..."))
(dolist (o (overlays-in (point-min) (point-max)))
(when (eq (overlay-get o 'org-type) 'org-blocked-todo)
@@ -3890,7 +3887,7 @@ dimming them."
(overlay-put ov 'face 'org-agenda-dimmed-todo-face))
(overlay-put ov 'org-type 'org-blocked-todo))))
(forward-line))))
- (when (org-called-interactively-p 'interactive)
+ (when (called-interactively-p 'interactive)
(message "Dim or hide blocked tasks...done")))
(defvar org-agenda-skip-function nil
@@ -3942,7 +3939,7 @@ functions do."
(defvar org-agenda-markers nil
"List of all currently active markers created by `org-agenda'.")
-(defvar org-agenda-last-marker-time (org-float-time)
+(defvar org-agenda-last-marker-time (float-time)
"Creation time of the last agenda marker.")
(defun org-agenda-new-marker (&optional pos)
@@ -3950,7 +3947,7 @@ functions do."
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))
+ (setq org-agenda-last-marker-time (float-time))
(if org-agenda-buffer
(with-current-buffer org-agenda-buffer
(push m org-agenda-markers))
@@ -4011,13 +4008,12 @@ This check for agenda markers in all agenda buffers currently active."
(defun org-agenda-get-day-face (date)
"Return the face DATE should be displayed with."
- (or (and (functionp org-agenda-day-face-function)
- (funcall org-agenda-day-face-function date))
- (cond ((org-agenda-todayp date)
- 'org-agenda-date-today)
- ((member (calendar-day-of-week date) org-agenda-weekend-days)
- 'org-agenda-date-weekend)
- (t 'org-agenda-date))))
+ (cond ((and (functionp org-agenda-day-face-function)
+ (funcall org-agenda-day-face-function date)))
+ ((org-agenda-today-p date) 'org-agenda-date-today)
+ ((memq (calendar-day-of-week date) org-agenda-weekend-days)
+ 'org-agenda-date-weekend)
+ (t 'org-agenda-date)))
;;; Agenda timeline
@@ -4025,12 +4021,16 @@ This check for agenda markers in all agenda buffers currently active."
(defvar org-agenda-show-log-scoped) ;; dynamically scope in `org-timeline' or `org-agenda-list'
(defun org-timeline (&optional dotodo)
- "Show a time-sorted view of the entries in the current org file.
-Only entries with a time stamp of today or later will be listed. With
-\\[universal-argument] prefix, all unfinished TODO items will also be shown,
+ "Show a time-sorted view of the entries in the current Org file.
+
+Only entries with a time stamp of today or later will be listed.
+
+With `\\[universal-argument]' prefix, all unfinished TODO items will also be \
+shown,
under the current date.
-If the buffer contains an active region, only check the region for
-dates."
+
+If the buffer contains an active region, only check the region
+for dates."
(interactive "P")
(let* ((dopast t)
(org-agenda-show-log-scoped org-agenda-show-log)
@@ -4213,8 +4213,7 @@ items if they have an hour specification like [h]h:mm."
(setq start-day (time-to-days (org-read-date nil t start-day))))
(org-compile-prefix-format 'agenda)
(org-set-sorting-strategy 'agenda)
- (let* ((span (org-agenda-ndays-to-span
- (or span org-agenda-ndays org-agenda-span)))
+ (let* ((span (org-agenda-ndays-to-span (or span org-agenda-span)))
(today (org-today))
(sd (or start-day today))
(ndays (org-agenda-span-to-ndays span sd))
@@ -4244,9 +4243,9 @@ items if they have an hour specification like [h]h:mm."
(setq day-numbers (nreverse day-numbers))
(setq clocktable-start (car day-numbers)
clocktable-end (1+ (or (org-last day-numbers) 0)))
- (org-set-local 'org-starting-day (car day-numbers))
- (org-set-local 'org-arg-loc arg)
- (org-set-local 'org-agenda-current-span (org-agenda-ndays-to-span span))
+ (setq-local org-starting-day (car day-numbers))
+ (setq-local org-arg-loc arg)
+ (setq-local org-agenda-current-span (org-agenda-ndays-to-span span))
(unless org-agenda-compact-blocks
(let* ((d1 (car day-numbers))
(d2 (org-last day-numbers))
@@ -4392,10 +4391,10 @@ START-DAY is an absolute time value."
((eq span 'fortnight) 14)
((eq span 'month)
(let ((date (calendar-gregorian-from-absolute start-day)))
- (calendar-last-day-of-month (car date) (caddr date))))
+ (calendar-last-day-of-month (car date) (cl-caddr date))))
((eq span 'year)
(let ((date (calendar-gregorian-from-absolute start-day)))
- (if (calendar-leap-year-p (caddr date)) 366 365)))))
+ (if (calendar-leap-year-p (cl-caddr date)) 366 365)))))
(defun org-agenda-span-name (span)
"Return a SPAN name."
@@ -4410,7 +4409,7 @@ START-DAY is an absolute time value."
(defvar org-agenda-search-history nil)
(defvar org-search-syntax-table nil
- "Special syntax table for org-mode search.
+ "Special syntax table for Org search.
In this table, we have single quotes not as word constituents, to
that when \"+Ameli\" is searched as a work, it will also match \"Ameli's\"")
@@ -4727,7 +4726,7 @@ Press `\\[org-agenda-manipulate-query-add]', \
(defun org-todo-list (&optional arg)
"Show all (not done) TODO entries from all agenda file in a single list.
The prefix arg can be used to select a specific TODO keyword and limit
-the list to these. When using \\[universal-argument], you will be prompted
+the list to these. When using `\\[universal-argument]', you will be prompted
for a keyword. A numeric prefix directly selects the Nth keyword in
`org-todo-keywords-1'."
(interactive "P")
@@ -4745,8 +4744,8 @@ for a keyword. A numeric prefix directly selects the Nth keyword in
rtn rtnall files file pos)
(when (equal arg '(4))
(setq org-select-this-todo-keyword
- (org-icompleting-read "Keyword (or KWD1|K2D2|...): "
- (mapcar 'list kwds) nil nil)))
+ (completing-read "Keyword (or KWD1|K2D2|...): "
+ (mapcar #'list kwds) nil nil)))
(and (equal 0 arg) (setq org-select-this-todo-keyword nil))
(catch 'exit
(if org-agenda-sticky
@@ -4835,14 +4834,17 @@ The prefix arg TODO-ONLY limits the search to TODO entries."
;; Prepare agendas (and `org-tag-alist-for-agenda') before
;; expanding tags within `org-make-tags-matcher'
(org-agenda-prepare (concat "TAGS " match))
- (setq matcher (org-make-tags-matcher match)
- match (car matcher) matcher (cdr matcher))
+ (setq org--matcher-tags-todo-only todo-only
+ matcher (org-make-tags-matcher match)
+ match (car matcher)
+ matcher (cdr matcher))
(org-compile-prefix-format 'tags)
(org-set-sorting-strategy 'tags)
(setq org-agenda-query-string match)
(setq org-agenda-redo-command
- (list 'org-tags-view `(quote ,todo-only)
- (list 'if 'current-prefix-arg nil `(quote ,org-agenda-query-string))))
+ (list 'org-tags-view
+ `(quote ,org--matcher-tags-todo-only)
+ `(if current-prefix-arg nil ,org-agenda-query-string)))
(setq files (org-agenda-files nil 'ifmode)
rtnall nil)
(while (setq file (pop files))
@@ -4865,7 +4867,9 @@ The prefix arg TODO-ONLY limits the search to TODO entries."
(narrow-to-region org-agenda-restrict-begin
org-agenda-restrict-end)
(widen))
- (setq rtn (org-scan-tags 'agenda matcher todo-only))
+ (setq rtn (org-scan-tags 'agenda
+ matcher
+ org--matcher-tags-todo-only))
(setq rtnall (append rtnall rtn))))))))
(if org-agenda-overriding-header
(insert (org-add-props (copy-sequence org-agenda-overriding-header)
@@ -4883,17 +4887,19 @@ The prefix arg TODO-ONLY limits the search to TODO entries."
(insert (substitute-command-keys
"Press `\\[universal-argument] \\[org-agenda-redo]' \
to search again with new search string\n")))
- (add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure)))
+ (add-text-properties pos (1- (point))
+ (list 'face 'org-agenda-structure)))
(org-agenda-mark-header-line (point-min))
(when rtnall
(insert (org-agenda-finalize-entries rtnall 'tags) "\n"))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
- (add-text-properties (point-min) (point-max)
- `(org-agenda-type tags
- org-last-args (,todo-only ,match)
- org-redo-cmd ,org-agenda-redo-command
- org-series-cmd ,org-cmd))
+ (add-text-properties
+ (point-min) (point-max)
+ `(org-agenda-type tags
+ org-last-args (,org--matcher-tags-todo-only ,match)
+ org-redo-cmd ,org-agenda-redo-command
+ org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t))))
@@ -5102,12 +5108,12 @@ of what a project is and how to check if it stuck, customize the variable
(tags (nth 2 org-stuck-projects))
(tags-re (if (member "*" tags)
(concat org-outline-regexp-bol
- (org-re ".*:[[:alnum:]_@#%]+:[ \t]*$"))
+ ".*:[[:alnum:]_@#%]+:[ \t]*$")
(if tags
(concat org-outline-regexp-bol
".*:\\("
- (mapconcat 'identity tags "\\|")
- (org-re "\\):[[:alnum:]_@#%:]*[ \t]*$")))))
+ (mapconcat #'identity tags "\\|")
+ "\\):[[:alnum:]_@#%:]*[ \t]*$"))))
(gen-re (nth 3 org-stuck-projects))
(re-list
(delq nil
@@ -5202,7 +5208,7 @@ date. It also removes lines that contain only whitespace."
(while (re-search-forward "^ +\n" nil t)
(replace-match ""))
(goto-char (point-min))
- (if (re-search-forward "^Org-mode dummy\n?" nil t)
+ (if (re-search-forward "^Org mode dummy\n?" nil t)
(replace-match ""))
(run-hooks 'org-agenda-cleanup-fancy-diary-hook))
@@ -5220,7 +5226,7 @@ date. It also removes lines that contain only whitespace."
(setq string (org-modify-diary-entry-string string))))))
(defun org-modify-diary-entry-string (string)
- "Add text properties to string, allowing org-mode to act on it."
+ "Add text properties to string, allowing Org to act on it."
(org-add-props string nil
'mouse-face 'highlight
'help-echo (if buffer-file-name
@@ -5236,9 +5242,9 @@ Needed to avoid empty dates which mess up holiday display."
;; Catch the error if dealing with the new add-to-diary-alist
(when org-disable-agenda-to-diary
(condition-case nil
- (org-add-to-diary-list original-date "Org-mode dummy" "")
+ (org-add-to-diary-list original-date "Org mode dummy" "")
(error
- (org-add-to-diary-list original-date "Org-mode dummy" "" nil)))))
+ (org-add-to-diary-list original-date "Org mode dummy" "" nil)))))
(defun org-add-to-diary-list (&rest args)
(if (fboundp 'diary-add-to-list)
@@ -5274,7 +5280,7 @@ So the example above may also be written as
The function expects the lisp variables `entry' and `date' to be provided
by the caller, because this is how the calendar works. Don't use this
function from a program - use `org-agenda-get-day-entries' instead."
- (when (> (- (org-float-time)
+ (when (> (- (float-time)
org-agenda-last-marker-time)
5)
;; I am not sure if this works with sticky agendas, because the marker
@@ -5286,7 +5292,7 @@ function from a program - use `org-agenda-get-day-entries' instead."
(let* ((files (if (and entry (stringp entry) (string-match "\\S-" entry))
(list entry)
(org-agenda-files t)))
- (time (org-float-time))
+ (time (float-time))
file rtn results)
(when (or (not org-diary-last-run-time)
(> (- time
@@ -5308,67 +5314,77 @@ function from a program - use `org-agenda-get-day-entries' instead."
;;; Agenda entry finders
+(defun org-agenda--timestamp-to-absolute (&rest args)
+ "Call `org-time-string-to-absolute' with ARGS.
+However, throw `:skip' whenever an error is raised."
+ (condition-case e
+ (apply #'org-time-string-to-absolute args)
+ (org-diary-sexp-no-match (throw :skip nil))
+ (error
+ (message "%s; Skipping entry" (error-message-string e))
+ (throw :skip nil))))
+
(defun org-agenda-get-day-entries (file date &rest args)
"Does the work for `org-diary' and `org-agenda'.
FILE is the path to a file to be checked for entries. DATE is date like
the one returned by `calendar-current-date'. ARGS are symbols indicating
which kind of entries should be extracted. For details about these, see
the documentation of `org-diary'."
- (setq args (or args org-agenda-entry-types))
(let* ((org-startup-folded nil)
(org-startup-align-all-tables nil)
- (buffer (if (file-exists-p file)
- (org-get-agenda-file-buffer file)
- (error "No such file %s" file)))
- arg results rtn deadline-results)
+ (buffer (if (file-exists-p file) (org-get-agenda-file-buffer file)
+ (error "No such file %s" file))))
(if (not buffer)
- ;; If file does not exist, make sure an error message ends up in diary
+ ;; If file does not exist, signal it in diary nonetheless.
(list (format "ORG-AGENDA-ERROR: No such org-file %s" file))
(with-current-buffer buffer
(unless (derived-mode-p 'org-mode)
(error "Agenda file %s is not in `org-mode'" file))
(setq org-agenda-buffer (or org-agenda-buffer buffer))
- (let ((case-fold-search nil))
- (save-excursion
- (save-restriction
- (if (eq buffer org-agenda-restrict)
- (narrow-to-region org-agenda-restrict-begin
- org-agenda-restrict-end)
- (widen))
- ;; The way we repeatedly append to `results' makes it O(n^2) :-(
- (while (setq arg (pop args))
- (cond
- ((and (eq arg :todo)
- (equal date (calendar-gregorian-from-absolute
- (org-today))))
- (setq rtn (org-agenda-get-todos))
- (setq results (append results rtn)))
- ((eq arg :timestamp)
- (setq rtn (org-agenda-get-blocks))
- (setq results (append results rtn))
- (setq rtn (org-agenda-get-timestamps deadline-results))
- (setq results (append results rtn)))
- ((eq arg :sexp)
- (setq rtn (org-agenda-get-sexps))
- (setq results (append results rtn)))
- ((eq arg :scheduled)
- (setq rtn (org-agenda-get-scheduled deadline-results))
- (setq results (append results rtn)))
- ((eq arg :scheduled*)
- (setq rtn (org-agenda-get-scheduled deadline-results t))
- (setq results (append results rtn)))
- ((eq arg :closed)
- (setq rtn (org-agenda-get-progress))
- (setq results (append results rtn)))
- ((eq arg :deadline)
- (setq rtn (org-agenda-get-deadlines))
- (setq deadline-results (copy-sequence rtn))
- (setq results (append results rtn)))
- ((eq arg :deadline*)
- (setq rtn (org-agenda-get-deadlines t))
- (setq deadline-results (copy-sequence rtn))
- (setq results (append results rtn))))))))
- results))))
+ (setf org-agenda-current-date date)
+ (save-excursion
+ (save-restriction
+ (if (eq buffer org-agenda-restrict)
+ (narrow-to-region org-agenda-restrict-begin
+ org-agenda-restrict-end)
+ (widen))
+ ;; Rationalize ARGS. Also make sure `:deadline' comes
+ ;; first in order to populate DEADLINES before passing it.
+ ;;
+ ;; We use `delq' since `org-uniquify' duplicates ARGS,
+ ;; guarding us from modifying `org-agenda-entry-types'.
+ (setf args (org-uniquify (or args org-agenda-entry-types)))
+ (when (and (memq :scheduled args) (memq :scheduled* args))
+ (setf args (delq :scheduled* args)))
+ (cond
+ ((memq :deadline args)
+ (setf args (cons :deadline
+ (delq :deadline (delq :deadline* args)))))
+ ((memq :deadline* args)
+ (setf args (cons :deadline* (delq :deadline* args)))))
+ ;; Collect list of headlines. Return them flattened.
+ (let ((case-fold-search nil) results deadlines)
+ (dolist (arg args (apply #'nconc (nreverse results)))
+ (pcase arg
+ ((and :todo (guard (org-agenda-today-p date)))
+ (push (org-agenda-get-todos) results))
+ (:timestamp
+ (push (org-agenda-get-blocks) results)
+ (push (org-agenda-get-timestamps deadlines) results))
+ (:sexp
+ (push (org-agenda-get-sexps) results))
+ (:scheduled
+ (push (org-agenda-get-scheduled deadlines) results))
+ (:scheduled*
+ (push (org-agenda-get-scheduled deadlines t) results))
+ (:closed
+ (push (org-agenda-get-progress) results))
+ (:deadline
+ (setf deadlines (org-agenda-get-deadlines))
+ (push deadlines results))
+ (:deadline*
+ (setf deadlines (org-agenda-get-deadlines t))
+ (push deadlines results)))))))))))
(defsubst org-em (x y list)
"Is X or Y a member of LIST?"
@@ -5524,7 +5540,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
(cond
((memq org-agenda-todo-ignore-deadlines '(t all)) t)
((eq org-agenda-todo-ignore-deadlines 'far)
- (not (org-deadline-close (match-string 1))))
+ (not (org-deadline-close-p (match-string 1))))
((eq org-agenda-todo-ignore-deadlines 'future)
(> (org-time-stamp-to-now
(match-string 1) org-agenda-todo-ignore-time-comparison-use-seconds) 0))
@@ -5534,7 +5550,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
((numberp org-agenda-todo-ignore-deadlines)
(org-agenda-todo-custom-ignore-p
(match-string 1) org-agenda-todo-ignore-deadlines))
- (t (org-deadline-close (match-string 1)))))
+ (t (org-deadline-close-p (match-string 1)))))
(and org-agenda-todo-ignore-timestamp
(let ((buffer (current-buffer))
(regexp
@@ -5610,7 +5626,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
(and (org-at-date-range-p) (throw :skip nil))
(org-agenda-skip)
(if (and (match-end 1)
- (not (= d1 (org-time-string-to-absolute
+ (not (= d1 (org-agenda--timestamp-to-absolute
(match-string 1) d1 nil show-all
(current-buffer) b0))))
(throw :skip nil))
@@ -5656,8 +5672,8 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags-at nil (not inherited-tags))
level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
- (setq head (or (match-string 1) ""))
+ (looking-at "\\*+[ \t]+\\(.*\\)")
+ (setq head (match-string 1))
(setq txt (org-agenda-format-item
(if inactivep org-agenda-inactive-leader nil)
head level category tags timestr
@@ -5737,29 +5753,26 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
;; Calendar sanity: define some functions that are independent of
;; `calendar-date-style'.
-;; Normally I would like to use ISO format when calling the diary functions,
-;; but to make sure we still have Emacs 22 compatibility we bind
-;; also `european-calendar-style' and use european format
(defun org-anniversary (year month day &optional mark)
"Like `diary-anniversary', but with fixed (ISO) order of arguments."
- (org-no-warnings
- (let ((calendar-date-style 'european) (european-calendar-style t))
- (diary-anniversary day month year mark))))
+ (with-no-warnings
+ (let ((calendar-date-style 'iso))
+ (diary-anniversary year month day mark))))
(defun org-cyclic (N year month day &optional mark)
"Like `diary-cyclic', but with fixed (ISO) order of arguments."
- (org-no-warnings
- (let ((calendar-date-style 'european) (european-calendar-style t))
- (diary-cyclic N day month year mark))))
+ (with-no-warnings
+ (let ((calendar-date-style 'iso))
+ (diary-cyclic N year month day mark))))
(defun org-block (Y1 M1 D1 Y2 M2 D2 &optional mark)
"Like `diary-block', but with fixed (ISO) order of arguments."
- (org-no-warnings
- (let ((calendar-date-style 'european) (european-calendar-style t))
- (diary-block D1 M1 Y1 D2 M2 Y2 mark))))
+ (with-no-warnings
+ (let ((calendar-date-style 'iso))
+ (diary-block Y1 M1 D1 Y2 M2 D2 mark))))
(defun org-date (year month day &optional mark)
"Like `diary-date', but with fixed (ISO) order of arguments."
- (org-no-warnings
- (let ((calendar-date-style 'european) (european-calendar-style t))
- (diary-date day month year mark))))
+ (with-no-warnings
+ (let ((calendar-date-style 'iso))
+ (diary-date year month day mark))))
;; Define the `org-class' function
(defun org-class (y1 m1 d1 y2 m2 d2 dayname &rest skip-weeks)
@@ -5786,26 +5799,6 @@ then those holidays will be skipped."
(delq nil (mapcar (lambda(g) (member g skip-weeks)) h))))
entry)))
-(defun org-diary-class (m1 d1 y1 m2 d2 y2 dayname &rest skip-weeks)
- "Like `org-class', but honor `calendar-date-style'.
-The order of the first 2 times 3 arguments depends on the variable
-`calendar-date-style' or, if that is not defined, on `european-calendar-style'.
-So for American calendars, give this as MONTH DAY YEAR, for European as
-DAY MONTH YEAR, and for ISO as YEAR MONTH DAY.
-DAYNAME is a number between 0 (Sunday) and 6 (Saturday). SKIP-WEEKS
-is any number of ISO weeks in the block period for which the item should
-be skipped.
-
-This function is here only for backward compatibility and it is deprecated,
-please use `org-class' instead."
- (let* ((date1 (org-order-calendar-date-args m1 d1 y1))
- (date2 (org-order-calendar-date-args m2 d2 y2)))
- (org-class
- (nth 2 date1) (car date1) (nth 1 date1)
- (nth 2 date2) (car date2) (nth 1 date2)
- dayname skip-weeks)))
-(make-obsolete 'org-diary-class 'org-class "")
-
(defalias 'org-get-closed 'org-agenda-get-progress)
(defun org-agenda-get-progress ()
"Return the logged TODO entries for agenda display."
@@ -5919,7 +5912,7 @@ See also the user option `org-agenda-clock-consistency-checks'."
(re (concat "^[ \t]*"
org-clock-string
"[ \t]+"
- "\\(\\[.*?\\]\\)" ; group 1 is first stamp
+ "\\(\\[.*?\\]\\)" ; group 1 is first stamp
"\\(-\\{1,3\\}\\(\\[.*?\\]\\)\\)?")) ; group 3 is second
(tlstart 0.)
(tlend 0.)
@@ -5955,10 +5948,10 @@ See also the user option `org-agenda-clock-consistency-checks'."
(throw 'next t))
(setq ts (match-string 1)
te (match-string 3)
- ts (org-float-time
- (apply 'encode-time (org-parse-time-string ts)))
- te (org-float-time
- (apply 'encode-time (org-parse-time-string te)))
+ ts (float-time
+ (apply #'encode-time (org-parse-time-string ts)))
+ te (float-time
+ (apply #'encode-time (org-parse-time-string te)))
dt (- te ts))))
(cond
((> dt (* 60 maxtime))
@@ -6044,123 +6037,124 @@ specification like [h]h:mm."
(regexp (if with-hour
org-deadline-time-hour-regexp
org-deadline-time-regexp))
- (todayp (org-agenda-todayp date)) ; DATE bound by calendar
- (d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar
- (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 level
- tags suppress-prewarning ee txt head face s todo-state
- show-all upcomingp donep timestr warntime inherited-tags ts-date)
+ (todayp (org-agenda-today-p date)) ; DATE bound by calendar.
+ (current (calendar-absolute-from-gregorian date))
+ deadline-items)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
+ (unless (save-match-data (org-at-planning-p)) (throw :skip nil))
(org-agenda-skip)
- (setq s (match-string 1)
- txt nil
- pos (1- (match-beginning 1))
- todo-state (save-match-data (org-get-todo-state))
- show-all (or (eq org-agenda-repeating-timestamp-show-all t)
- (member todo-state
- org-agenda-repeating-timestamp-show-all))
- d2 (org-time-string-to-absolute
- s d1 'past show-all (current-buffer) pos)
- diff (- d2 d1))
- (setq suppress-prewarning
- (let ((ds (and org-agenda-skip-deadline-prewarning-if-scheduled
- (let ((item (buffer-substring (point-at-bol)
- (point-at-eol))))
- (save-match-data
- (and (string-match
- org-scheduled-time-regexp item)
- (match-string 1 item)))))))
- (cond
- ((not ds) nil)
- ;; The current item has a scheduled date (in ds), so
- ;; evaluate its prewarning lead time.
- ((integerp org-agenda-skip-deadline-prewarning-if-scheduled)
- ;; Use global prewarning-restart lead time.
- org-agenda-skip-deadline-prewarning-if-scheduled)
- ((eq org-agenda-skip-deadline-prewarning-if-scheduled
- 'pre-scheduled)
- ;; Set prewarning to no earlier than scheduled.
- (min (- d2 (org-time-string-to-absolute
- ds d1 'past show-all (current-buffer) pos))
- org-deadline-warning-days))
- ;; Set prewarning to deadline.
- (t 0))))
- (setq wdays (if suppress-prewarning
- (let ((org-deadline-warning-days suppress-prewarning))
- (org-get-wdays s))
- (org-get-wdays s))
- dfrac (- 1 (/ (* 1.0 diff) (max wdays 1)))
- upcomingp (and todayp (> diff 0)))
- ;; When to show a deadline in the calendar:
- ;; If the expiration is within wdays warning time.
- ;; Past-due deadlines are only shown on the current date
- (if (and (or (and (<= diff wdays)
- (and todayp (not org-agenda-only-exact-dates)))
- (= diff 0)))
- (save-excursion
- ;; (setq todo-state (org-get-todo-state))
- (setq donep (member todo-state org-done-keywords))
- (if (and donep
- (or org-agenda-skip-deadline-if-done
- (not (= diff 0))))
- (setq txt nil)
- (setq category (org-get-category)
- warntime (get-text-property (point) 'org-appt-warntime))
- (if (not (re-search-backward "^\\*+[ \t]+" nil t))
- (throw :skip nil)
- (goto-char (match-end 0))
- (setq pos1 (match-beginning 0))
- (setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (setq inherited-tags
- (or (eq org-agenda-show-inherited-tags 'always)
- (and (listp org-agenda-show-inherited-tags)
- (memq 'agenda org-agenda-show-inherited-tags))
- (and (eq org-agenda-show-inherited-tags t)
- (or (eq org-agenda-use-tag-inheritance t)
- (memq 'agenda org-agenda-use-tag-inheritance))))
- tags (org-get-tags-at pos1 (not inherited-tags)))
- (setq head (buffer-substring
- (point)
- (progn (skip-chars-forward "^\r\n")
- (point))))
- (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
- (setq timestr
- (concat (substring s (match-beginning 1)) " "))
- (setq timestr 'time))
- (setq txt (org-agenda-format-item
- (cond ((= diff 0) dl0)
- ((> diff 0)
- (if (functionp dl1)
- (funcall dl1 diff date)
- (format dl1 diff)))
- (t
- (if (functionp dl2)
- (funcall dl2 diff date)
- (format dl2 (if (string= dl2 dl1)
- diff (abs diff))))))
- head level category tags
- (if (not (= diff 0)) nil timestr)))))
- (when txt
- (setq face (org-agenda-deadline-face dfrac))
- (org-add-props txt props
- 'org-marker (org-agenda-new-marker pos)
- 'warntime warntime
- 'level level
- 'ts-date d2
- 'org-hd-marker (org-agenda-new-marker pos1)
- 'priority (+ (- diff)
- (org-get-priority txt))
- 'todo-state todo-state
- 'type (if upcomingp "upcoming-deadline" "deadline")
- 'date (if upcomingp date d2)
- 'face (if donep 'org-agenda-done face)
- 'undone-face face 'done-face 'org-agenda-done)
- (push txt ee))))))
- (nreverse ee)))
+ (let* ((s (match-string 1))
+ (pos (1- (match-beginning 1)))
+ (todo-state (save-match-data (org-get-todo-state)))
+ (donep (member todo-state org-done-keywords))
+ (show-all (or (eq org-agenda-repeating-timestamp-show-all t)
+ (member todo-state
+ org-agenda-repeating-timestamp-show-all)))
+ ;; DEADLINE is the current scheduled date. When it
+ ;; contains a repeater and SHOW-ALL is non-nil,
+ ;; LAST-REPEAT is the repeat closest to CURRENT.
+ ;; Otherwise, LAST-REPEAT is equal to DEADLINE.
+ (last-repeat (org-agenda--timestamp-to-absolute
+ s current 'past show-all (current-buffer) pos))
+ (deadline (org-agenda--timestamp-to-absolute s current))
+ (diff (- last-repeat current))
+ (suppress-prewarning
+ (let ((scheduled
+ (and org-agenda-skip-deadline-prewarning-if-scheduled
+ (org-entry-get nil "SCHEDULED"))))
+ (cond
+ ((not scheduled) nil)
+ ;; The current item has a scheduled date, so
+ ;; evaluate its prewarning lead time.
+ ((integerp org-agenda-skip-deadline-prewarning-if-scheduled)
+ ;; Use global prewarning-restart lead time.
+ org-agenda-skip-deadline-prewarning-if-scheduled)
+ ((eq org-agenda-skip-deadline-prewarning-if-scheduled
+ 'pre-scheduled)
+ ;; Set pre-warning to no earlier than SCHEDULED.
+ (min (- last-repeat
+ (org-agenda--timestamp-to-absolute
+ scheduled current 'past show-all
+ (current-buffer)
+ (save-excursion
+ (beginning-of-line)
+ (1+ (search-forward org-deadline-string)))))
+ org-deadline-warning-days))
+ ;; Set pre-warning to deadline.
+ (t 0))))
+ (wdays (if suppress-prewarning
+ (let ((org-deadline-warning-days suppress-prewarning))
+ (org-get-wdays s))
+ (org-get-wdays s))))
+ ;; When to show a deadline in the calendar: if the
+ ;; expiration is within WDAYS warning time. Past-due
+ ;; deadlines are only shown on the current date
+ (unless (or (and (<= diff wdays)
+ (and todayp (not org-agenda-only-exact-dates)))
+ (= diff 0))
+ (throw :skip nil))
+ ;; Skip done tasks if `org-agenda-skip-deadline-if-done' is
+ ;; non-nil or if it isn't applicable to CURRENT deadline.
+ (when (and donep
+ (or org-agenda-skip-deadline-if-done
+ (/= deadline current)))
+ (throw :skip nil))
+ (save-excursion
+ (re-search-backward "^\\*+[ \t]+" nil t)
+ (goto-char (match-end 0))
+ (let* ((category (org-get-category))
+ (level
+ (make-string (org-reduced-level (org-outline-level)) ?\s))
+ (head (buffer-substring (point) (line-end-position)))
+ (inherited-tags
+ (or (eq org-agenda-show-inherited-tags 'always)
+ (and (listp org-agenda-show-inherited-tags)
+ (memq 'agenda org-agenda-show-inherited-tags))
+ (and (eq org-agenda-show-inherited-tags t)
+ (or (eq org-agenda-use-tag-inheritance t)
+ (memq 'agenda
+ org-agenda-use-tag-inheritance)))))
+ (tags (org-get-tags-at nil (not inherited-tags)))
+ (timestr
+ (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
+ (concat (substring s (match-beginning 1)) " ")
+ 'time))
+ (item
+ (org-agenda-format-item
+ ;; For past deadlines, make sure to report time
+ ;; difference since date S, not since closest
+ ;; repeater.
+ (let ((diff (if (< (org-today) current) diff
+ (- deadline current))))
+ (if (= diff 0) (car org-agenda-deadline-leaders)
+ (let ((future (nth 1 org-agenda-deadline-leaders))
+ (past (nth 2 org-agenda-deadline-leaders)))
+ (cond ((> diff 0) (format future diff))
+ ((string= future past) (format past diff))
+ (t (format past (abs diff)))))))
+ head level category tags
+ (and (= diff 0) timestr)))
+ (face (org-agenda-deadline-face
+ (- 1 (/ (float (- deadline current)) (max wdays 1)))))
+ (upcomingp (and todayp (> diff 0)))
+ (warntime (get-text-property (point) 'org-appt-warntime)))
+ (org-add-props item props
+ 'org-marker (org-agenda-new-marker pos)
+ 'org-hd-marker (org-agenda-new-marker (line-beginning-position))
+ 'warntime warntime
+ 'level level
+ 'ts-date deadline
+ 'priority (- (org-get-priority item) diff)
+ 'todo-state todo-state
+ 'type (if upcomingp "upcoming-deadline" "deadline")
+ 'date (if upcomingp date deadline)
+ 'face (if donep 'org-agenda-done face)
+ 'undone-face face
+ 'done-face 'org-agenda-done)
+ (push item deadline-items))))))
+ (nreverse deadline-items)))
(defun org-agenda-deadline-face (fraction)
"Return the face to displaying a deadline item.
@@ -6170,10 +6164,11 @@ FRACTION is what fraction of the head-warning time has passed."
(while (setq f (pop faces))
(if (>= fraction (car f)) (throw 'exit (cdr f)))))))
-(defun org-agenda-get-scheduled (&optional deadline-results with-hour)
+(defun org-agenda-get-scheduled (&optional deadlines with-hour)
"Return the scheduled information for agenda display.
-When WITH-HOUR is non-nil, only return scheduled items with
-an hour specification like [h]h:mm."
+Optional argument DEADLINES is a list of deadline items to be
+displayed in agenda view. When WITH-HOUR is non-nil, only return
+scheduled items with an hour specification like [h]h:mm."
(let* ((props (list 'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
@@ -6185,165 +6180,167 @@ an hour specification like [h]h:mm."
(regexp (if with-hour
org-scheduled-time-hour-regexp
org-scheduled-time-regexp))
- (todayp (org-agenda-todayp date)) ; DATE bound by calendar
- (d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar
- mm
- (deadline-position-alist
- (mapcar (lambda (a) (and (setq mm (get-text-property
- 0 'org-hd-marker a))
- (cons (marker-position mm) a)))
- deadline-results))
- 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)
+ (todayp (org-agenda-today-p date)) ; DATE bound by calendar.
+ (current (calendar-absolute-from-gregorian date))
+ (deadline-pos
+ (mapcar (lambda (d)
+ (let ((m (get-text-property 0 'org-hd-marker d)))
+ (and m (marker-position m))))
+ deadlines))
+ scheduled-items)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
+ (unless (save-match-data (org-at-planning-p)) (throw :skip nil))
(org-agenda-skip)
- (setq s (match-string 1)
- txt nil
- pos (1- (match-beginning 1))
- todo-state (save-match-data (org-get-todo-state))
- show-all (or (eq org-agenda-repeating-timestamp-show-all t)
- (member todo-state
- org-agenda-repeating-timestamp-show-all))
- d2 (org-time-string-to-absolute
- s d1 'past show-all (current-buffer) pos)
- diff (- d2 d1)
- warntime (get-text-property (point) 'org-appt-warntime))
- (setq pastschedp (and todayp (< diff 0)))
- (setq did-habit-check-p nil)
- (setq suppress-delay
- (let ((ds (and org-agenda-skip-scheduled-delay-if-deadline
- (let ((item (buffer-substring (point-at-bol) (point-at-eol))))
- (save-match-data
- (and (string-match
- org-deadline-time-regexp item)
- (match-string 1 item)))))))
+ (let* ((s (match-string 1))
+ (pos (1- (match-beginning 1)))
+ (todo-state (save-match-data (org-get-todo-state)))
+ (donep (member todo-state org-done-keywords))
+ (show-all (or (eq org-agenda-repeating-timestamp-show-all t)
+ (member todo-state
+ org-agenda-repeating-timestamp-show-all)))
+ ;; SCHEDULE is the current scheduled date. When it
+ ;; contains a repeater and SHOW-ALL is non-nil,
+ ;; LAST-REPEAT is the repeat closest to CURRENT.
+ ;; Otherwise, LAST-REPEAT is equal to SCHEDULE.
+ (last-repeat (org-agenda--timestamp-to-absolute
+ s current 'past show-all (current-buffer) pos))
+ (schedule (org-agenda--timestamp-to-absolute s current))
+ (diff (- last-repeat current))
+ (warntime (get-text-property (point) 'org-appt-warntime))
+ (pastschedp (< schedule (org-today)))
+ (habitp (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
+ (suppress-delay
+ (let ((deadline (and org-agenda-skip-scheduled-delay-if-deadline
+ (org-entry-get nil "DEADLINE"))))
+ (cond
+ ((not deadline) nil)
+ ;; The current item has a deadline date, so
+ ;; evaluate its delay time.
+ ((integerp org-agenda-skip-scheduled-delay-if-deadline)
+ ;; Use global delay time.
+ (- org-agenda-skip-scheduled-delay-if-deadline))
+ ((eq org-agenda-skip-scheduled-delay-if-deadline
+ 'post-deadline)
+ ;; Set delay to no later than DEADLINE. If
+ ;; DEADLINE has a repeater, compare last schedule
+ ;; repeat and last deadline repeat.
+ (min (- last-repeat
+ (org-agenda--timestamp-to-absolute
+ deadline current 'past show-all
+ (current-buffer)
+ (save-excursion
+ (beginning-of-line)
+ (1+ (search-forward org-deadline-string)))))
+ org-scheduled-delay-days))
+ (t 0))))
+ (ddays
(cond
- ((not ds) nil)
- ;; The current item has a deadline date (in ds), so
- ;; evaluate its delay time.
- ((integerp org-agenda-skip-scheduled-delay-if-deadline)
- ;; Use global delay time.
- (- org-agenda-skip-scheduled-delay-if-deadline))
- ((eq org-agenda-skip-scheduled-delay-if-deadline
- 'post-deadline)
- ;; Set delay to no later than deadline.
- (min (- d2 (org-time-string-to-absolute
- ds d1 'past show-all (current-buffer) pos))
- org-scheduled-delay-days))
- (t 0))))
- (setq ddays (if suppress-delay
- (let ((org-scheduled-delay-days suppress-delay))
- (org-get-wdays s t t))
- (org-get-wdays s t)))
- ;; Use a delay of 0 when there is a repeater and the delay is
- ;; of the form --3d
- (when (and (save-match-data (string-match "--[0-9]+[hdwmy]" s))
- (< (org-time-string-to-absolute s)
- (org-time-string-to-absolute
- s d2 'past nil (current-buffer) pos)))
- (setq ddays 0))
- ;; When to show a scheduled item in the calendar:
- ;; If it is on or past the date.
- (when (or (and (> ddays 0) (= diff (- ddays)))
- (and (zerop ddays) (= diff 0))
- (and (< (+ diff ddays) 0)
- (< (abs diff) org-scheduled-past-days)
- (and todayp (not org-agenda-only-exact-dates)))
- ;; org-is-habit-p uses org-entry-get, which is expansive
- ;; so we go extra mile to only call it once
- (and todayp
- (boundp 'org-habit-show-all-today)
- org-habit-show-all-today
- (setq did-habit-check-p t)
- (setq habitp (and (functionp 'org-is-habit-p)
- (org-is-habit-p)))))
- (save-excursion
- (setq donep (member todo-state org-done-keywords))
- (if (and donep
+ ;; Nullify delay when a repeater triggered already
+ ;; and the delay is of the form --Xd.
+ ((and (string-match-p "--[0-9]+[hdwmy]" s)
+ (/= schedule last-repeat))
+ 0)
+ (suppress-delay
+ (let ((org-scheduled-delay-days suppress-delay))
+ (org-get-wdays s t t)))
+ (t (org-get-wdays s t)))))
+ ;; Only show a scheduled item in the calendar if it is on or
+ ;; past the current date. Skip it if it has been displayed
+ ;; for more than `org-scheduled-past-days'.
+ (unless (or (and (>= ddays 0) (= diff (- ddays)))
+ (and (< (+ diff ddays) 0)
+ (< (abs diff) org-scheduled-past-days)
+ (and todayp (not org-agenda-only-exact-dates)))
+ (and todayp
+ habitp
+ (bound-and-true-p org-habit-show-all-today)))
+ (throw :skip nil))
+ ;; Skip done habits, or tasks if
+ ;; `org-agenda-skip-deadline-if-done' is non-nil or if it
+ ;; was scheduled in the past anyway.
+ (when (and donep
(or org-agenda-skip-scheduled-if-done
- (not (= diff 0))
- (and (functionp 'org-is-habit-p)
- (org-is-habit-p))))
- (setq txt nil)
- (setq habitp (if did-habit-check-p habitp
- (and (functionp 'org-is-habit-p)
- (org-is-habit-p))))
- (setq category (org-get-category))
- (if (and (eq org-agenda-skip-scheduled-if-deadline-is-shown
- 'repeated-after-deadline)
- (org-get-deadline-time (point))
- (<= 0 (- d2 (time-to-days (org-get-deadline-time (point))))))
- (throw :skip nil))
- (if (not (re-search-backward "^\\*+[ \t]+" nil t))
- (throw :skip nil)
- (goto-char (match-end 0))
- (setq pos1 (match-beginning 0))
- (if habitp
- (if (or (not org-habit-show-habits)
- (and (not todayp)
- (boundp 'org-habit-show-habits-only-for-today)
- org-habit-show-habits-only-for-today))
- (throw :skip nil))
- (if (and
- (or (eq t org-agenda-skip-scheduled-if-deadline-is-shown)
- (and (eq org-agenda-skip-scheduled-if-deadline-is-shown 'not-today)
- pastschedp))
- (setq mm (assoc pos1 deadline-position-alist)))
- (throw :skip nil)))
- (setq inherited-tags
- (or (eq org-agenda-show-inherited-tags 'always)
- (and (listp org-agenda-show-inherited-tags)
- (memq 'agenda org-agenda-show-inherited-tags))
- (and (eq org-agenda-show-inherited-tags t)
- (or (eq org-agenda-use-tag-inheritance t)
- (memq 'agenda org-agenda-use-tag-inheritance))))
-
- tags (org-get-tags-at nil (not inherited-tags)))
- (setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (setq head (buffer-substring
- (point)
- (progn (skip-chars-forward "^\r\n") (point))))
- (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
- (setq timestr
- (concat (substring s (match-beginning 1)) " "))
- (setq timestr 'time))
- (setq txt (org-agenda-format-item
- (if (= diff 0)
- (car org-agenda-scheduled-leaders)
- (format (nth 1 org-agenda-scheduled-leaders)
- (- 1 diff)))
- head level category tags
- (if (not (= diff 0)) nil timestr)
- nil habitp))))
- (when txt
- (setq face
- (cond
- ((and (not habitp) pastschedp)
- 'org-scheduled-previously)
- (todayp 'org-scheduled-today)
- (t 'org-scheduled))
- habitp (and habitp (org-habit-parse-todo)))
- (org-add-props txt props
+ (/= schedule current)
+ habitp))
+ (throw :skip nil))
+ ;; Skip entry if it already appears as a deadline, per
+ ;; `org-agenda-skip-scheduled-if-deadline-is-shown'. This
+ ;; doesn't apply to habits.
+ (when (pcase org-agenda-skip-scheduled-if-deadline-is-shown
+ ((guard
+ (or (not (memq (line-beginning-position 0) deadline-pos))
+ habitp))
+ nil)
+ (`repeated-after-deadline
+ (>= last-repeat
+ (time-to-days (org-get-deadline-time (point)))))
+ (`not-today pastschedp)
+ (`t t)
+ (_ nil))
+ (throw :skip nil))
+ ;; Skip habits if `org-habit-show-habits' is nil, or if we
+ ;; only show them for today.
+ (when (and habitp
+ (or (not (bound-and-true-p org-habit-show-habits))
+ (and (not todayp)
+ (bound-and-true-p
+ org-habit-show-habits-only-for-today))))
+ (throw :skip nil))
+ (save-excursion
+ (re-search-backward "^\\*+[ \t]+" nil t)
+ (goto-char (match-end 0))
+ (let* ((category (org-get-category))
+ (inherited-tags
+ (or (eq org-agenda-show-inherited-tags 'always)
+ (and (listp org-agenda-show-inherited-tags)
+ (memq 'agenda org-agenda-show-inherited-tags))
+ (and (eq org-agenda-show-inherited-tags t)
+ (or (eq org-agenda-use-tag-inheritance t)
+ (memq 'agenda
+ org-agenda-use-tag-inheritance)))))
+ (tags (org-get-tags-at nil (not inherited-tags)))
+ (level
+ (make-string (org-reduced-level (org-outline-level)) ?\s))
+ (head (buffer-substring (point) (line-end-position)))
+ (timestr
+ (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
+ (concat (substring s (match-beginning 1)) " ")
+ 'time))
+ (item (org-agenda-format-item
+ ;; For past scheduled dates, make sure to
+ ;; report time difference since SCHEDULE,
+ ;; not since closest repeater.
+ (let ((diff (if (< (org-today) current) diff
+ (- schedule current))))
+ (if (= diff 0) (car org-agenda-scheduled-leaders)
+ (format (nth 1 org-agenda-scheduled-leaders)
+ (- 1 diff))))
+ head level category tags
+ (and (= diff 0) timestr)
+ nil habitp))
+ (face (cond ((and (not habitp) pastschedp)
+ 'org-scheduled-previously)
+ (todayp 'org-scheduled-today)
+ (t 'org-scheduled)))
+ (habitp (and habitp (org-habit-parse-todo))))
+ (org-add-props item props
'undone-face face
'face (if donep 'org-agenda-done face)
'org-marker (org-agenda-new-marker pos)
- 'org-hd-marker (org-agenda-new-marker pos1)
+ 'org-hd-marker (org-agenda-new-marker (line-beginning-position))
'type (if pastschedp "past-scheduled" "scheduled")
- 'date (if pastschedp d2 date)
- 'ts-date d2
+ 'date (if pastschedp schedule date)
+ 'ts-date schedule
'warntime warntime
'level level
- 'priority (if habitp
- (org-habit-get-priority habitp)
- (+ 94 (- 5 diff) (org-get-priority txt)))
+ 'priority (if habitp (org-habit-get-priority habitp)
+ (+ 94 (- 5 diff) (org-get-priority item)))
'org-habit-p habitp
'todo-state todo-state)
- (push txt ee))))))
- (nreverse ee)))
+ (push item scheduled-items))))))
+ (nreverse scheduled-items)))
(defun org-agenda-get-blocks ()
"Return the date-range information for agenda display."
@@ -6394,7 +6391,7 @@ an hour specification like [h]h:mm."
tags (org-get-tags-at nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
- (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (looking-at "\\*+[ \t]+\\(.*\\)")
(setq head (match-string 1))
(let ((remove-re
(if org-agenda-remove-timeranges-from-blocks
@@ -6449,10 +6446,10 @@ The flag is set if the currently compiled format contains a `%b'.")
(defun org-agenda-get-category-icon (category)
"Return an image for CATEGORY according to `org-agenda-category-icon-alist'."
(dolist (entry org-agenda-category-icon-alist)
- (when (org-string-match-p (car entry) category)
+ (when (string-match-p (car entry) category)
(if (listp (cadr entry))
- (return (cadr entry))
- (return (apply 'create-image (cdr entry)))))))
+ (cl-return (cadr entry))
+ (cl-return (apply #'create-image (cdr entry)))))))
(defun org-agenda-format-item (extra txt &optional level category tags dotime
remove-re habitp)
@@ -6479,8 +6476,8 @@ Any match of REMOVE-RE will be removed from TXT."
;; buffer
(let* ((bindings (car org-prefix-format-compiled))
(formatter (cadr org-prefix-format-compiled)))
- (loop for (var value) in bindings
- do (set var value))
+ (cl-loop for (var value) in bindings
+ do (set var value))
(save-match-data
;; Diary entries sometimes have extra whitespace at the beginning
(setq txt (org-trim txt))
@@ -6550,8 +6547,7 @@ Any match of REMOVE-RE will be removed from TXT."
(setq duration (- (org-hh:mm-string-to-minutes s2)
(org-hh:mm-string-to-minutes s1)))))
- (when (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")
- txt)
+ (when (string-match "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$" txt)
;; Tags are in the string
(if (or (eq org-agenda-remove-tags t)
(and org-agenda-remove-tags
@@ -6626,7 +6622,7 @@ Any match of REMOVE-RE will be removed from TXT."
The modified list may contain inherited tags, and tags matched by
`org-agenda-hide-tags-regexp' will be removed."
(when (or add-inherited hide-re)
- (if (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") txt)
+ (if (string-match "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$" txt)
(setq txt (substring txt 0 (match-beginning 0))))
(setq tags
(delq nil
@@ -6731,12 +6727,12 @@ and stored in the variable `org-prefix-format-compiled'."
c (or (match-string 3 s) "")
opt (match-beginning 1)
start (1+ (match-beginning 0)))
- (if (equal var 'time) (setq org-prefix-has-time t))
- (if (equal var 'tag) (setq org-prefix-has-tag t))
- (if (equal var 'effort) (setq org-prefix-has-effort t))
- (if (equal var 'breadcrumbs) (setq org-prefix-has-breadcrumbs t))
+ (if (eq var 'time) (setq org-prefix-has-time t))
+ (if (eq var 'tag) (setq org-prefix-has-tag t))
+ (if (eq var 'effort) (setq org-prefix-has-effort t))
+ (if (eq var 'breadcrumbs) (setq org-prefix-has-breadcrumbs t))
(setq f (concat "%" (match-string 2 s) "s"))
- (when (equal var 'category)
+ (when (eq var 'category)
(setq org-prefix-category-length
(floor (abs (string-to-number (match-string 2 s)))))
(setq org-prefix-category-max-length
@@ -6959,8 +6955,14 @@ The optional argument TYPE tells the agenda type."
(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- (length a)) 'effort-minutes a) def))
- (eb (or (get-text-property (1- (length b)) 'effort-minutes b) def)))
+ ;; `effort-minutes' property is not directly accessible from
+ ;; the strings, but is stored as a property in `txt'.
+ (ea (or (get-text-property
+ 0 'effort-minutes (get-text-property 0 'txt a))
+ def))
+ (eb (or (get-text-property
+ 0 'effort-minutes (get-text-property 0 'txt b))
+ def)))
(cond ((> ea eb) +1)
((< ea eb) -1))))
@@ -7122,7 +7124,7 @@ their type."
'face 'org-agenda-restriction-lock)
(overlay-put org-agenda-restriction-lock-overlay
'help-echo "Agendas are currently limited to this subtree.")
-(org-detach-overlay org-agenda-restriction-lock-overlay)
+(delete-overlay org-agenda-restriction-lock-overlay)
;;;###autoload
(defun org-agenda-set-restriction-lock (&optional type)
@@ -7168,8 +7170,8 @@ in the file. Otherwise, restriction will be to the current subtree."
(defun org-agenda-remove-restriction-lock (&optional noupdate)
"Remove the agenda restriction lock."
(interactive "P")
- (org-detach-overlay org-agenda-restriction-lock-overlay)
- (org-detach-overlay org-speedbar-restriction-lock-overlay)
+ (delete-overlay org-agenda-restriction-lock-overlay)
+ (delete-overlay org-speedbar-restriction-lock-overlay)
(setq org-agenda-overriding-restriction nil)
(setq org-agenda-restrict nil)
(put 'org-agenda-files 'org-restrict nil)
@@ -7358,7 +7360,7 @@ in the agenda."
(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))
+ (and cols (called-interactively-p 'any) (org-agenda-columns))
(org-goto-line line)
(recenter window-line)))
@@ -7447,19 +7449,19 @@ With two prefix arguments, remove the effort filters."
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)))
+ (cl-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"))))
@@ -7480,15 +7482,18 @@ With two prefix arguments, remove the effort filters."
(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 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."
+
+The tag is selected with its fast selection letter, as configured.
+
+With a `\\[universal-argument]' prefix, exclude the agenda search.
+
+With a `\\[universal-argument] \\[universal-argument]' prefix, 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
@@ -7517,10 +7522,10 @@ to switch between filtering and excluding."
((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)))
+ (setq-local org-global-tags-completion-table
+ (org-global-tags-completion-table)))
(let ((completion-ignore-case t))
- (setq tag (org-icompleting-read
+ (setq tag (completing-read
"Tag: " org-global-tags-completion-table))))
(cond
((eq char ?\r)
@@ -7565,12 +7570,6 @@ to switch between filtering and excluding."
(get-text-property (point) 'tags))))
tags))
-(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 arg char))
-(make-obsolete 'org-agenda-filter-by-tag-refine
- "use `org-agenda-filter-by-tag' instead." "8.3.4")
(defun org-agenda-filter-make-matcher (filter type &optional expand)
"Create the form that tests a line for agenda filter. Optional
@@ -7623,30 +7622,22 @@ tags in the FILTER if any of the tags in FILTER are grouptags."
(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)
+ "Return a form associated to tag-expression TAGS.
+Build a form testing a line for agenda filter for
+tag-expressions. OP is an operator of type CHAR that allows the
+function to set the right switches in the returned form."
+ (let (form)
+ ;; Any of the expressions can match if OP is +, all must match if
+ ;; the operator is -.
+ (dolist (x tags (cons (if (eq op ?-) 'and 'or) form))
(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))))
+ (f (cond
+ ((string= "" tag) '(not tags))
+ ((and (string-match-p "\\`{" tag) (string-match-p "}\\'" tag))
+ ;; TAG is a regexp.
+ (list 'org-match-any-p (substring tag 1 -1) 'tags))
+ (t (list 'member (downcase tag) 'tags)))))
+ (push (if (eq op ?-) (list 'not f) f) form)))))
(defun org-agenda-filter-effort-form (e)
"Return the form to compare the effort of the current line with what E says.
@@ -7860,7 +7851,7 @@ Negative selection means regexp must not match for selection of an entry."
(tdpos (goto-char tdpos))
((eq org-agenda-type 'agenda)
(let* ((sd (org-agenda-compute-starting-span
- (org-today) (or curspan org-agenda-ndays org-agenda-span)))
+ (org-today) (or curspan org-agenda-span)))
(org-agenda-overriding-arguments args))
(setf (nth 1 org-agenda-overriding-arguments) sd)
(org-agenda-redo)
@@ -7960,36 +7951,35 @@ With prefix ARG, go backward that many times the current span."
(message "View: [d]ay [w]eek for[t]night [m]onth [y]ear [SPC]reset [q]uit/abort
time[G]rid [[]inactive [f]ollow [l]og [L]og-all [c]lockcheck
[a]rch-trees [A]rch-files clock[R]eport include[D]iary [E]ntryText")
- (let ((a (read-char-exclusive)))
- (case a
- (?\ (call-interactively 'org-agenda-reset-view))
- (?d (call-interactively 'org-agenda-day-view))
- (?w (call-interactively 'org-agenda-week-view))
- (?t (call-interactively 'org-agenda-fortnight-view))
- (?m (call-interactively 'org-agenda-month-view))
- (?y (call-interactively 'org-agenda-year-view))
- (?l (call-interactively 'org-agenda-log-mode))
- (?L (org-agenda-log-mode '(4)))
- (?c (org-agenda-log-mode 'clockcheck))
- ((?F ?f) (call-interactively 'org-agenda-follow-mode))
- (?a (call-interactively 'org-agenda-archives-mode))
- (?A (org-agenda-archives-mode 'files))
- ((?R ?r) (call-interactively 'org-agenda-clockreport-mode))
- ((?E ?e) (call-interactively 'org-agenda-entry-text-mode))
- (?G (call-interactively 'org-agenda-toggle-time-grid))
- (?D (call-interactively 'org-agenda-toggle-diary))
- (?\! (call-interactively 'org-agenda-toggle-deadlines))
- (?\[ (let ((org-agenda-include-inactive-timestamps t))
- (org-agenda-check-type t 'timeline 'agenda)
- (org-agenda-redo))
- (message "Display now includes inactive timestamps as well"))
- (?q (message "Abort"))
- (otherwise (error "Invalid key" )))))
+ (pcase (read-char-exclusive)
+ (?\ (call-interactively 'org-agenda-reset-view))
+ (?d (call-interactively 'org-agenda-day-view))
+ (?w (call-interactively 'org-agenda-week-view))
+ (?t (call-interactively 'org-agenda-fortnight-view))
+ (?m (call-interactively 'org-agenda-month-view))
+ (?y (call-interactively 'org-agenda-year-view))
+ (?l (call-interactively 'org-agenda-log-mode))
+ (?L (org-agenda-log-mode '(4)))
+ (?c (org-agenda-log-mode 'clockcheck))
+ ((or ?F ?f) (call-interactively 'org-agenda-follow-mode))
+ (?a (call-interactively 'org-agenda-archives-mode))
+ (?A (org-agenda-archives-mode 'files))
+ ((or ?R ?r) (call-interactively 'org-agenda-clockreport-mode))
+ ((or ?E ?e) (call-interactively 'org-agenda-entry-text-mode))
+ (?G (call-interactively 'org-agenda-toggle-time-grid))
+ (?D (call-interactively 'org-agenda-toggle-diary))
+ (?\! (call-interactively 'org-agenda-toggle-deadlines))
+ (?\[ (let ((org-agenda-include-inactive-timestamps t))
+ (org-agenda-check-type t 'timeline 'agenda)
+ (org-agenda-redo))
+ (message "Display now includes inactive timestamps as well"))
+ (?q (message "Abort"))
+ (key (user-error "Invalid key: %s" key))))
(defun org-agenda-reset-view ()
"Switch to default view for agenda."
(interactive)
- (org-agenda-change-time-span (or org-agenda-ndays org-agenda-span)))
+ (org-agenda-change-time-span org-agenda-span))
(defun org-agenda-day-view (&optional day-of-month)
"Switch to daily view for agenda.
With argument DAY-OF-MONTH, switch to that day of the month."
@@ -8128,7 +8118,7 @@ so that the date SD will be in that range."
(defun org-unhighlight ()
"Detach overlay INDEX."
- (org-detach-overlay org-hl))
+ (delete-overlay org-hl))
(defun org-unhighlight-once ()
"Remove the highlight from its position, and this function from the hook."
@@ -8185,9 +8175,11 @@ so that the date SD will be in that range."
(defun org-agenda-log-mode (&optional special)
"Toggle log mode in an agenda buffer.
+
With argument SPECIAL, show all possible log items, not only the ones
configured in `org-agenda-log-mode-items'.
-With a double \\[universal-argument] prefix arg, show *only* \
+
+With a `\\[universal-argument] \\[universal-argument]' prefix, show *only* \
log items, nothing else."
(interactive "P")
(org-agenda-check-type t 'agenda 'timeline)
@@ -8202,8 +8194,7 @@ log items, nothing else."
(setq org-agenda-start-with-log-mode org-agenda-show-log)
(org-agenda-set-mode-name)
(org-agenda-redo)
- (message "Log mode is %s"
- (if org-agenda-show-log "on" "off")))
+ (message "Log mode is %s" (if org-agenda-show-log "on" "off")))
(defun org-agenda-archives-mode (&optional with-files)
"Toggle inclusion of items in trees marked with :ARCHIVE:.
@@ -8275,7 +8266,7 @@ When called with a prefix argument, include all archive files as well."
(t ""))
(if (or org-agenda-category-filter
(get 'org-agenda-category-filter :preset-filter))
- '(:eval (org-propertize
+ '(:eval (propertize
(concat " <"
(mapconcat
'identity
@@ -8288,7 +8279,7 @@ When called with a prefix argument, include all archive files as well."
'help-echo "Category used in filtering")) "")
(if (or org-agenda-tag-filter
(get 'org-agenda-tag-filter :preset-filter))
- '(:eval (org-propertize
+ '(:eval (propertize
(concat " {"
(mapconcat
'identity
@@ -8301,7 +8292,7 @@ When called with a prefix argument, include all archive files as well."
'help-echo "Tags used in filtering")) "")
(if (or org-agenda-effort-filter
(get 'org-agenda-effort-filter :preset-filter))
- '(:eval (org-propertize
+ '(:eval (propertize
(concat " {"
(mapconcat
'identity
@@ -8314,7 +8305,7 @@ When called with a prefix argument, include all archive files as well."
'help-echo "Effort conditions used in filtering")) "")
(if (or org-agenda-regexp-filter
(get 'org-agenda-regexp-filter :preset-filter))
- '(:eval (org-propertize
+ '(:eval (propertize
(concat " ["
(mapconcat
'identity
@@ -8333,9 +8324,6 @@ When called with a prefix argument, include all archive files as well."
(if org-agenda-clockreport-mode " Clock" "")))
(force-mode-line-update))
-(define-obsolete-function-alias
- 'org-agenda-post-command-hook 'org-agenda-update-agenda-type "24.3")
-
(defun org-agenda-update-agenda-type ()
"Update the agenda type after each command."
(setq org-agenda-type
@@ -8398,7 +8386,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 entry at point in the corresponding Org-mode file."
+ "Go to the entry at point in the corresponding Org file."
(interactive)
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
@@ -8410,15 +8398,11 @@ When called with a prefix argument, include all archive files as well."
(goto-char pos)
(when (derived-mode-p 'org-mode)
(org-show-context 'agenda)
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
- (when (outline-invisible-p)
- (outline-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))))
+ (let ((case-fold-search nil))
+ (when (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)))))
@@ -8505,7 +8489,7 @@ Point is in the buffer where the item originated.")
(org-remove-subtree-entries-from-agenda))
(org-back-to-heading t)
(funcall cmd)))
- (error "Archiving works only in Org-mode files"))))))
+ (error "Archiving works only in Org files"))))))
(defun org-remove-subtree-entries-from-agenda (&optional buf beg end)
"Remove all lines in the agenda that correspond to a given subtree.
@@ -8535,11 +8519,16 @@ 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) or a triple \\[universal-argument] prefix argument,
-clear the refile cache.
-When GOTO is \\='(16) or a double \\[universal-argument] prefix argument,
-go to the location of the last refiled item.
+When called with `\\[universal-argument] \\[universal-argument]', \
+go to the location of the last
+refiled item.
+
+When called with `\\[universal-argument] \\[universal-argument] \
+\\[universal-argument]' prefix or when GOTO is 0, clear
+the refile cache.
+
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")
(cond
@@ -8558,13 +8547,11 @@ When NO-UPDATE is non-nil, don't redo the agenda buffer."
(if goto "Goto" "Refile to") buffer
org-refile-allow-creating-parent-nodes))))
(with-current-buffer buffer
- (save-excursion
- (save-restriction
- (widen)
- (goto-char marker)
- (let ((org-agenda-buffer-name buffer-orig))
- (org-remove-subtree-entries-from-agenda))
- (org-refile goto buffer rfloc)))))
+ (org-with-wide-buffer
+ (goto-char marker)
+ (let ((org-agenda-buffer-name buffer-orig))
+ (org-remove-subtree-entries-from-agenda))
+ (org-refile goto buffer rfloc))))
(unless no-update (org-agenda-redo)))))
(defun org-agenda-open-link (&optional arg)
@@ -8589,13 +8576,11 @@ It also looks at the text of the entry itself."
(setq trg (and (string-match org-bracket-link-regexp l)
(match-string 1 l)))
(if (or (not trg) (string-match org-any-link-re trg))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char marker)
- (when (search-forward l nil lkend)
- (goto-char (match-beginning 0))
- (org-open-at-point))))
+ (org-with-wide-buffer
+ (goto-char marker)
+ (when (search-forward l nil lkend)
+ (goto-char (match-beginning 0))
+ (org-open-at-point)))
;; This is an internal link, widen the buffer
(switch-to-buffer-other-window buffer)
(widen)
@@ -8615,8 +8600,9 @@ It also looks at the text of the entry itself."
"Get a variable from a referenced buffer and install it here."
(let ((m (org-get-at-bol 'org-marker)))
(when (and m (buffer-live-p (marker-buffer m)))
- (org-set-local var (with-current-buffer (marker-buffer m)
- (symbol-value var))))))
+ (set (make-local-variable var)
+ (with-current-buffer (marker-buffer m)
+ (symbol-value var))))))
(defun org-agenda-switch-to (&optional delete-other-windows)
"Go to the Org mode file which contains the item at point.
@@ -8632,7 +8618,7 @@ displayed Org file fills the frame."
(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)
+ (pop-to-buffer-same-window buffer)
(when delete-other-windows (delete-other-windows))
(widen)
(goto-char pos)
@@ -8641,13 +8627,13 @@ displayed Org file fills the frame."
(run-hooks 'org-agenda-after-show-hook)))))
(defun org-agenda-goto-mouse (ev)
- "Go to the Org-mode file which contains the item at the mouse click."
+ "Go to the Org file which contains the item at the mouse click."
(interactive "e")
(mouse-set-point ev)
(org-agenda-goto))
(defun org-agenda-show (&optional full-entry)
- "Display the Org-mode file which contains the item at point.
+ "Display the Org file which contains the item at point.
With prefix argument FULL-ENTRY, make the entire entry visible
if it was hidden in the outline."
(interactive "P")
@@ -8658,11 +8644,13 @@ if it was hidden in the outline."
(defvar org-agenda-show-window nil)
(defun org-agenda-show-and-scroll-up (&optional arg)
- "Display the Org-mode file which contains the item at point.
+ "Display the Org file which contains the item at point.
+
When called repeatedly, scroll the window that is displaying the buffer.
-With a \\[universal-argument] prefix, use `org-show-entry' instead of
-`show-subtree' to display the item, so that drawers and logbooks stay
-folded."
+
+With a `\\[universal-argument]' prefix, use `org-show-entry' instead of \
+`outline-show-subtree'
+to display the item, so that drawers and logbooks stay folded."
(interactive "P")
(let ((win (selected-window)))
(if (and (window-live-p org-agenda-show-window)
@@ -8685,7 +8673,7 @@ folded."
(select-window win))))
(defun org-agenda-show-1 (&optional more)
- "Display the Org-mode file which contains the item at point.
+ "Display the Org file which contains the item at point.
The prefix arg selects the amount of information to display:
0 hide the subtree
@@ -8708,11 +8696,11 @@ if it was hidden in the outline."
(org-back-to-heading)
(run-hook-with-args 'org-cycle-hook 'folded))
(message "Remote: FOLDED"))
- ((and (org-called-interactively-p 'any) (= more 1))
+ ((and (called-interactively-p 'any) (= more 1))
(message "Remote: show with default settings"))
((= more 2)
(outline-show-entry)
- (outline-show-children)
+ (org-show-children)
(save-excursion
(org-back-to-heading)
(run-hook-with-args 'org-cycle-hook 'children))
@@ -8760,7 +8748,7 @@ docstring of `org-agenda-show-1'."
(org-agenda-show-1 org-agenda-cycle-counter))
(defun org-agenda-recenter (arg)
- "Display the Org-mode file which contains the item at point and recenter."
+ "Display the Org file which contains the item at point and recenter."
(interactive "P")
(let ((win (selected-window)))
(org-agenda-goto t)
@@ -8768,7 +8756,7 @@ docstring of `org-agenda-show-1'."
(select-window win)))
(defun org-agenda-show-mouse (ev)
- "Display the Org-mode file which contains the item at the mouse click."
+ "Display the Org file which contains the item at the mouse click."
(interactive "e")
(mouse-set-point ev)
(org-agenda-show))
@@ -8788,8 +8776,10 @@ This calls the command `org-tree-to-indirect-buffer' from the original buffer.
With a numerical prefix ARG, go up to this level and then take that tree.
With a negative numeric ARG, go up by this number of levels.
-With a \\[universal-argument] prefix, make a separate frame for this tree (i.e. don't
-use the dedicated frame)."
+
+With a `\\[universal-argument]' prefix, make a separate frame for this tree, \
+i.e. don't use
+the dedicated frame."
(interactive "P")
(if current-prefix-arg
(org-agenda-do-tree-to-indirect-buffer arg)
@@ -8837,9 +8827,9 @@ by a remote command from the agenda.")
(org-agenda-todo 'previousset))
(defun org-agenda-todo (&optional arg)
- "Cycle TODO state of line at point, also in Org-mode file.
+ "Cycle TODO state of line at point, also in Org file.
This changes the line at point, all other lines in the agenda referring to
-the same tree node, and the headline of the tree node in the Org-mode file."
+the same tree node, and the headline of the tree node in the Org file."
(interactive "P")
(org-agenda-check-no-diary)
(let* ((col (current-column))
@@ -8848,7 +8838,7 @@ the same tree node, and the headline of the tree node in the Org-mode file."
(buffer (marker-buffer marker))
(pos (marker-position marker))
(hdmarker (org-get-at-bol 'org-hd-marker))
- (todayp (org-agenda-todayp (org-get-at-bol 'day)))
+ (todayp (org-agenda-today-p (org-get-at-bol 'day)))
(inhibit-read-only t)
org-agenda-headline-snapshot-before-repeat newhead just-one)
(org-with-remote-undo buffer
@@ -8856,14 +8846,11 @@ the same tree node, and the headline of the tree node in the Org-mode file."
(widen)
(goto-char pos)
(org-show-context 'agenda)
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
(let ((current-prefix-arg arg))
(call-interactively 'org-todo))
(and (bolp) (forward-char 1))
(setq newhead (org-get-heading))
- (when (and (org-bound-and-true-p
+ (when (and (bound-and-true-p
org-agenda-headline-snapshot-before-repeat)
(not (equal org-agenda-headline-snapshot-before-repeat
newhead))
@@ -8876,7 +8863,7 @@ the same tree node, and the headline of the tree node in the Org-mode file."
(beginning-of-line 1)
(save-window-excursion
(org-agenda-change-all-lines newhead hdmarker 'fixface just-one))
- (when (org-bound-and-true-p org-clock-out-when-done)
+ (when (bound-and-true-p org-clock-out-when-done)
(string-match (concat "^" (regexp-opt org-done-keywords-for-agenda))
newhead)
(org-agenda-unmark-clocking-task))
@@ -8897,9 +8884,6 @@ the same tree node, and the headline of the tree node in the Org-mode file."
(widen)
(goto-char pos)
(org-show-context 'agenda)
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
(org-add-note))))
(defun org-agenda-change-all-lines (newhead hdmarker
@@ -8916,9 +8900,9 @@ If FORCE-TAGS is non nil, the car of it returns the new tags."
(line (org-current-line))
(org-agenda-buffer (current-buffer))
(thetags (with-current-buffer (marker-buffer hdmarker)
- (save-excursion (save-restriction (widen)
- (goto-char hdmarker)
- (org-get-tags-at)))))
+ (org-with-wide-buffer
+ (goto-char hdmarker)
+ (org-get-tags-at))))
props m pl undone-face done-face finish new dotime level cat tags)
(save-excursion
(goto-char (point-max))
@@ -8939,20 +8923,25 @@ If FORCE-TAGS is non nil, the car of it returns the new tags."
org-prefix-format-compiled))
(extra (org-get-at-bol 'extra)))
(with-current-buffer (marker-buffer hdmarker)
- (save-excursion
- (save-restriction
- (widen)
- (org-agenda-format-item extra newhead level cat tags dotime)))))
+ (org-with-wide-buffer
+ (org-agenda-format-item extra newhead level cat tags dotime))))
pl (text-property-any (point-at-bol) (point-at-eol) 'org-heading t)
undone-face (org-get-at-bol 'undone-face)
done-face (org-get-at-bol 'done-face))
(beginning-of-line 1)
(cond
- ((equal new "")
- (and (looking-at ".*\n?") (replace-match "")))
+ ((equal new "") (delete-region (point) (line-beginning-position 2)))
((looking-at ".*")
- (replace-match new t t)
- (beginning-of-line 1)
+ ;; When replacing the whole line, preserve bulk mark
+ ;; overlay, if any.
+ (let ((mark (catch :overlay
+ (dolist (o (overlays-in (point) (+ 2 (point))))
+ (when (eq (overlay-get o 'type)
+ 'org-marked-entry-overlay)
+ (throw :overlay o))))))
+ (replace-match new t t)
+ (beginning-of-line)
+ (when mark (move-overlay mark (point) (+ 2 (point)))))
(add-text-properties (point-at-bol) (point-at-eol) props)
(when fixface
(add-text-properties
@@ -8973,7 +8962,7 @@ If FORCE-TAGS is non nil, the car of it returns the new tags."
(let ((inhibit-read-only t) l c)
(save-excursion
(goto-char (if line (point-at-bol) (point-min)))
- (while (re-search-forward (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")
+ (while (re-search-forward "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$"
(if line (point-at-eol) nil) t)
(add-text-properties
(match-beginning 2) (match-end 2)
@@ -8997,19 +8986,19 @@ If FORCE-TAGS is non nil, the car of it returns the new tags."
(org-font-lock-add-tag-faces (point-max)))))
(defun org-agenda-priority-up ()
- "Increase the priority of line at point, also in Org-mode file."
+ "Increase the priority of line at point, also in Org file."
(interactive)
(org-agenda-priority 'up))
(defun org-agenda-priority-down ()
- "Decrease the priority of line at point, also in Org-mode file."
+ "Decrease the priority of line at point, also in Org file."
(interactive)
(org-agenda-priority 'down))
(defun org-agenda-priority (&optional force-direction)
- "Set the priority of line at point, also in Org-mode file.
+ "Set the priority of line at point, also in Org file.
This changes the line at point, all other lines in the agenda referring to
-the same tree node, and the headline of the tree node in the Org-mode file.
+the same tree node, and the headline of the tree node in the Org file.
Called with a universal prefix arg, show the priority instead of setting it."
(interactive "P")
(if (equal force-direction '(4))
@@ -9030,9 +9019,6 @@ Called with a universal prefix arg, show the priority instead of setting it."
(widen)
(goto-char pos)
(org-show-context 'agenda)
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
(funcall 'org-priority force-direction)
(end-of-line 1)
(setq newhead (org-get-heading)))
@@ -9044,7 +9030,7 @@ Called with a universal prefix arg, show the priority instead of setting it."
"Set tags for the current headline."
(interactive)
(org-agenda-check-no-diary)
- (if (and (org-region-active-p) (org-called-interactively-p 'any))
+ (if (and (org-region-active-p) (called-interactively-p 'any))
(call-interactively 'org-change-tag-in-region)
(let* ((hdmarker (or (org-get-at-bol 'org-hd-marker)
(org-agenda-error)))
@@ -9056,12 +9042,7 @@ Called with a universal prefix arg, show the priority instead of setting it."
(with-current-buffer buffer
(widen)
(goto-char pos)
- (save-excursion
- (org-show-context 'agenda))
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
- (goto-char pos)
+ (org-show-context 'agenda)
(if tag
(org-toggle-tag tag onoff)
(call-interactively 'org-set-tags))
@@ -9084,12 +9065,7 @@ Called with a universal prefix arg, show the priority instead of setting it."
(with-current-buffer buffer
(widen)
(goto-char pos)
- (save-excursion
- (org-show-context 'agenda))
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
- (goto-char pos)
+ (org-show-context 'agenda)
(call-interactively 'org-set-property)))))
(defun org-agenda-set-effort ()
@@ -9106,12 +9082,7 @@ Called with a universal prefix arg, show the priority instead of setting it."
(with-current-buffer buffer
(widen)
(goto-char pos)
- (save-excursion
- (org-show-context 'agenda))
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
- (goto-char pos)
+ (org-show-context 'agenda)
(call-interactively 'org-set-effort)
(end-of-line 1)
(setq newhead (org-get-heading)))
@@ -9132,9 +9103,6 @@ Called with a universal prefix arg, show the priority instead of setting it."
(widen)
(goto-char pos)
(org-show-context 'agenda)
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
(call-interactively 'org-toggle-archive-tag)
(end-of-line 1)
(setq newhead (org-get-heading)))
@@ -9248,18 +9216,10 @@ Called with a universal prefix arg, show the priority instead of setting it."
(when (equal marker (org-get-at-bol 'org-marker))
(remove-text-properties (point-at-bol) (point-at-eol) '(display))
(org-move-to-column (- (window-width) (length stamp)) t)
- (if (featurep 'xemacs)
- ;; Use `duplicable' property to trigger undo recording
- (let ((ex (make-extent nil nil))
- (gl (make-glyph stamp)))
- (set-glyph-face gl 'secondary-selection)
- (set-extent-properties
- ex (list 'invisible t 'end-glyph gl 'duplicable t))
- (insert-extent ex (1- (point)) (point-at-eol)))
- (add-text-properties
- (1- (point)) (point-at-eol)
- (list 'display (org-add-props stamp nil
- 'face '(secondary-selection default)))))
+ (add-text-properties
+ (1- (point)) (point-at-eol)
+ (list 'display (org-add-props stamp nil
+ 'face '(secondary-selection default))))
(beginning-of-line 1))
(beginning-of-line 0)))))
@@ -9341,7 +9301,6 @@ ARG is passed through to `org-deadline'."
(widen)
(goto-char pos)
(org-show-context 'agenda)
- (org-show-entry)
(org-cycle-hide-drawers 'children)
(org-clock-in arg)
(setq newhead (org-get-heading)))
@@ -9356,14 +9315,12 @@ ARG is passed through to `org-deadline'."
(let ((marker (make-marker)) (col (current-column)) newhead)
(org-with-remote-undo (marker-buffer org-clock-marker)
(with-current-buffer (marker-buffer org-clock-marker)
- (save-excursion
- (save-restriction
- (widen)
- (goto-char org-clock-marker)
- (org-back-to-heading t)
- (move-marker marker (point))
- (org-clock-out)
- (setq newhead (org-get-heading))))))
+ (org-with-wide-buffer
+ (goto-char org-clock-marker)
+ (org-back-to-heading t)
+ (move-marker marker (point))
+ (org-clock-out)
+ (setq newhead (org-get-heading)))))
(org-agenda-change-all-lines newhead marker)
(move-marker marker nil)
(org-move-to-column col)
@@ -9390,7 +9347,7 @@ buffer, display it in another window."
(cond (pos (goto-char pos))
;; If the currently clocked entry is not in the agenda
;; buffer, we visit it in another window:
- (org-clock-current-task
+ ((bound-and-true-p org-clock-current-task)
(org-switch-to-buffer-other-window (org-clock-goto)))
(t (message "No running clock, use `C-c C-x C-j' to jump to the most recent one")))))
@@ -9440,11 +9397,13 @@ buffer, display it in another window."
"Where in `org-agenda-diary-file' should new entries be added?
Valid values:
-date-tree in the date tree, as child of the date
-top-level as top-level entries at the end of the file."
+date-tree in the date tree, as first child of the date
+date-tree-last in the date tree, as last child of the date
+top-level as top-level entries at the end of the file."
:group 'org-agenda
:type '(choice
- (const :tag "in a date tree" date-tree)
+ (const :tag "first in a date tree" date-tree)
+ (const :tag "last in a date tree" date-tree-last)
(const :tag "as top level at end of file" top-level)))
(defcustom org-agenda-insert-diary-extract-time nil
@@ -9545,24 +9504,30 @@ a timestamp can be added there."
(insert text)
(org-end-of-meta-data)
(unless (bolp) (insert "\n"))
- (when org-adapt-indentation (org-indent-to-column 2)))
+ (when org-adapt-indentation (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.
+ "Make a new entry with TEXT as a child of the current subtree.
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)
+ (cond
+ ((eq org-agenda-insert-diary-strategy 'date-tree-last)
+ (end-of-line)
+ (org-insert-heading '(4) t)
+ (org-do-demote))
+ (t
+ (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)))
+ (unless (looking-at-p "^[ \t]*$") (save-excursion (insert "\n")))
+ (when org-adapt-indentation (indent-to-column col)))
(org-show-set-visibility 'lineage))
(defun org-agenda-diary-entry ()
@@ -9570,7 +9535,7 @@ a timestamp can be added there."
All the standard commands work: block, weekly etc.
When `org-agenda-diary-file' points to a file,
`org-agenda-diary-entry-in-org-file' is called instead to create
-entries in that Org-mode file."
+entries in that Org file."
(interactive)
(if (not (eq org-agenda-diary-file 'diary-file))
(org-agenda-diary-entry-in-org-file)
@@ -9675,7 +9640,7 @@ argument, latitude and longitude will be prompted for."
;;;###autoload
(defun org-calendar-goto-agenda ()
- "Compute the Org-mode agenda for the calendar date displayed at the cursor.
+ "Compute the Org agenda for the calendar date displayed at the cursor.
This is a command that has to be installed in `calendar-mode-map'."
(interactive)
;; Temporarily disable sticky agenda since user clearly wants to
@@ -9717,6 +9682,7 @@ This is a command that has to be installed in `calendar-mode-map'."
;;; Bulk commands
(defun org-agenda-bulk-marked-p ()
+ "Non-nil when current entry is marked for bulk action."
(eq (get-char-property (point-at-bol) 'type)
'org-marked-entry-overlay))
@@ -9758,9 +9724,12 @@ This is a command that has to be installed in `calendar-mode-map'."
(goto-char (next-single-property-change (point) 'org-hd-marker))
(while (and (re-search-forward regexp nil t)
(setq txt-at-point (get-text-property (point) 'txt)))
- (when (string-match regexp txt-at-point)
- (setq entries-marked (1+ entries-marked))
- (call-interactively 'org-agenda-bulk-mark))))
+ (if (get-char-property (point) 'invisible)
+ (beginning-of-line 2)
+ (when (string-match regexp txt-at-point)
+ (setq entries-marked (1+ entries-marked))
+ (call-interactively 'org-agenda-bulk-mark)))))
+
(if (not entries-marked)
(message "No entry matching this regexp."))))
@@ -9893,21 +9862,21 @@ The prefix arg is passed through to the command if possible."
redo-at-end t))
((equal action ?t)
- (setq state (org-icompleting-read
+ (setq state (completing-read
"Todo state: "
(with-current-buffer (marker-buffer (car entries))
- (mapcar 'list org-todo-keywords-1))))
+ (mapcar #'list org-todo-keywords-1))))
(setq cmd `(let ((org-inhibit-blocking t)
(org-inhibit-logging 'note))
(org-agenda-todo ,state))))
((memq action '(?- ?+))
- (setq tag (org-icompleting-read
+ (setq tag (completing-read
(format "Tag to %s: " (if (eq action ?+) "add" "remove"))
(with-current-buffer (marker-buffer (car entries))
(delq nil
- (mapcar (lambda (x)
- (if (stringp (car x)) x)) org-tag-alist)))))
+ (mapcar (lambda (x) (and (stringp (car x)) x))
+ org-current-tag-alist)))))
(setq cmd `(org-agenda-set-tags ,tag ,(if (eq action ?+) ''on ''off))))
((memq action '(?s ?d))
@@ -9917,8 +9886,15 @@ The prefix arg is passed through to the command if possible."
nil nil nil
(if (eq action ?s) "(Re)Schedule to" "(Re)Set Deadline to")
org-overriding-default-time)))
- (c1 (if (eq action ?s) 'org-agenda-schedule 'org-agenda-deadline)))
- (setq cmd `(eval '(,c1 arg ,time)))))
+ (c1 (if (eq action ?s) 'org-agenda-schedule
+ 'org-agenda-deadline)))
+ ;; Make sure to not prompt for a note when bulk
+ ;; rescheduling as Org cannot cope with simultaneous Org.
+ ;; Besides, it could be annoying depending on the number
+ ;; of items re-scheduled.
+ (setq cmd `(eval '(let ((org-log-reschedule
+ (and org-log-reschedule 'time)))
+ (,c1 arg ,time))))))
((equal action ?S)
(if (not (org-agenda-check-type nil 'agenda 'timeline 'todo))
@@ -9935,13 +9911,13 @@ The prefix arg is passed through to the command if possible."
(calendar-gregorian-from-absolute (org-today)))))
(dotimes (i (1+ dist))
(while (member day-of-week org-agenda-weekend-days)
- (incf distance)
- (incf day-of-week)
- (if (= day-of-week 7)
- (setq day-of-week 0)))
- (incf day-of-week)
- (if (= day-of-week 7)
- (setq day-of-week 0)))))
+ (cl-incf distance)
+ (cl-incf day-of-week)
+ (when (= day-of-week 7)
+ (setq day-of-week 0)))
+ (cl-incf day-of-week)
+ (when (= day-of-week 7)
+ (setq day-of-week 0)))))
;; silently fail when try to replan a sexp entry
(condition-case nil
(let* ((date (calendar-gregorian-from-absolute
@@ -9957,8 +9933,8 @@ The prefix arg is passed through to the command if possible."
((equal action ?f)
(setq cmd (list (intern
- (org-icompleting-read "Function: "
- obarray 'fboundp t nil nil)))))
+ (completing-read "Function: "
+ obarray 'fboundp t nil nil)))))
(t (user-error "Invalid bulk action")))
@@ -10083,8 +10059,9 @@ tag and (if present) the flagging note."
(replace-match "\n" t t))
(goto-char (point-min))
(select-window win)
- (message (substitute-command-keys "Flagging note pushed to kill ring. \
-Press \\[org-agenda-show-the-flagging-note] again to remove tag and note")))))
+ (message "%s" (substitute-command-keys "Flagging note pushed to \
+kill ring. Press `\\[org-agenda-show-the-flagging-note]' again to remove \
+tag and note")))))
(defun org-agenda-remove-flag (marker)
"Remove the FLAGGED tag and any flagging note in the entry."
@@ -10107,7 +10084,8 @@ Press \\[org-agenda-show-the-flagging-note] again to remove tag and note")))))
;;;###autoload
(defun org-agenda-to-appt (&optional refresh filter &rest args)
"Activate appointments found in `org-agenda-files'.
-With a \\[universal-argument] prefix, refresh the list of
+
+With a `\\[universal-argument]' prefix, refresh the list of \
appointments.
If FILTER is t, interactively prompt the user for a regular
@@ -10141,76 +10119,78 @@ to override `appt-message-warning-time'."
(if refresh (setq appt-time-msg-list nil))
(if (eq filter t)
(setq filter (read-from-minibuffer "Regexp filter: ")))
- (let* ((cnt 0) ; count added events
- (scope (or args '(:deadline* :scheduled* :timestamp)))
- (org-agenda-new-buffers nil)
- (org-deadline-warning-days 0)
- ;; Do not use `org-today' here because appt only takes
- ;; time and without date as argument, so it may pass wrong
- ;; information otherwise
- (today (org-date-to-gregorian
- (time-to-days (current-time))))
- (org-agenda-restrict nil)
- (files (org-agenda-files 'unrestricted)) entries file
- (org-agenda-buffer nil))
+ (let* ((cnt 0) ; count added events
+ (scope (or args '(:deadline* :scheduled* :timestamp)))
+ (org-agenda-new-buffers nil)
+ (org-deadline-warning-days 0)
+ ;; Do not use `org-today' here because appt only takes
+ ;; time and without date as argument, so it may pass wrong
+ ;; information otherwise
+ (today (org-date-to-gregorian
+ (time-to-days (current-time))))
+ (org-agenda-restrict nil)
+ (files (org-agenda-files 'unrestricted)) entries file
+ (org-agenda-buffer nil))
;; Get all entries which may contain an appt
(org-agenda-prepare-buffers files)
(while (setq file (pop files))
(setq entries
- (delq nil
- (append entries
- (apply 'org-agenda-get-day-entries
- file today scope)))))
+ (delq nil
+ (append entries
+ (apply 'org-agenda-get-day-entries
+ file today scope)))))
;; Map thru entries and find if we should filter them out
(mapc
- (lambda(x)
+ (lambda (x)
(let* ((evt (org-trim
- (replace-regexp-in-string
- org-bracket-link-regexp "\\3"
- (or (get-text-property 1 'txt 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))
- (and (functionp filter) (funcall filter x))
- (and (listp filter)
- (let ((cat-filter (cadr (assoc 'category filter)))
- (evt-filter (cadr (assoc 'headline filter))))
- (or (and (stringp cat-filter)
- (string-match cat-filter cat))
- (and (stringp evt-filter)
- (string-match evt-filter evt)))))))
- (wrn (get-text-property 1 'warntime x)))
- ;; FIXME: Shall we remove text-properties for the appt text?
- ;; (setq evt (set-text-properties 0 (length evt) nil evt))
- (when (and ok tod)
- (setq tod (concat "00" (number-to-string tod))
- tod (when (string-match
- "\\([0-9]\\{1,2\\}\\)\\([0-9]\\{2\\}\\)\\'" tod)
- (concat (match-string 1 tod) ":"
- (match-string 2 tod))))
- (if (version< emacs-version "23.3")
- (appt-add tod evt)
- (appt-add tod evt wrn))
- (setq cnt (1+ cnt))))) entries)
+ (replace-regexp-in-string
+ org-bracket-link-regexp "\\3"
+ (or (get-text-property 1 'txt 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))
+ (and (functionp filter) (funcall filter x))
+ (and (listp filter)
+ (let ((cat-filter (cadr (assq 'category filter)))
+ (evt-filter (cadr (assq 'headline filter))))
+ (or (and (stringp cat-filter)
+ (string-match cat-filter cat))
+ (and (stringp evt-filter)
+ (string-match evt-filter evt)))))))
+ (wrn (get-text-property 1 'warntime x)))
+ ;; FIXME: Shall we remove text-properties for the appt text?
+ ;; (setq evt (set-text-properties 0 (length evt) nil evt))
+ (when (and ok tod (not (string-match "\\`DONE\\|CANCELLED" evt)))
+ (setq tod (concat "00" (number-to-string tod)))
+ (setq tod (when (string-match
+ "\\([0-9]\\{1,2\\}\\)\\([0-9]\\{2\\}\\)\\'" tod)
+ (concat (match-string 1 tod) ":"
+ (match-string 2 tod))))
+ (when (if (version< emacs-version "23.3")
+ (appt-add tod evt)
+ (appt-add tod evt wrn))
+ (setq cnt (1+ cnt))))))
+ entries)
(org-release-buffers org-agenda-new-buffers)
(if (eq cnt 0)
- (message "No event to add")
+ (message "No event to add")
(message "Added %d event%s for today" cnt (if (> cnt 1) "s" "")))))
-(defun org-agenda-todayp (date)
- "Does DATE mean today, when considering `org-extend-today-until'?"
- (let ((today (org-today))
- (date (if (and date (listp date)) (calendar-absolute-from-gregorian date)
- date)))
- (eq date today)))
+(defun org-agenda-today-p (date)
+ "Non nil when DATE means today.
+DATE is either a list of the form (month day year) or a number of
+days as returned by `calendar-absolute-from-gregorian' or
+`org-today'. This function considers `org-extend-today-until'
+when defining today."
+ (eq (org-today)
+ (if (consp date) (calendar-absolute-from-gregorian date) date)))
(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* ((org-use-effective-time t)
- (hour (third (decode-time
- (org-current-time))))
+ (hour (nth 2 (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 4c6a8c3..6daed74 100644
--- a/lisp/org-archive.el
+++ b/lisp/org-archive.el
@@ -1,4 +1,4 @@
-;;; org-archive.el --- Archiving for Org-mode
+;;; org-archive.el --- Archiving for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2016 Free Software Foundation, Inc.
@@ -30,8 +30,9 @@
(require 'org)
-(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
+(declare-function org-element-type "org-element" (element))
(declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction))
+(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
(defcustom org-archive-default-command 'org-archive-subtree
"The default archiving command."
@@ -56,7 +57,7 @@ See `org-archive-to-archive-sibling' for more information."
(defcustom org-archive-mark-done nil
"Non-nil means mark entries as DONE when they are moved to the archive file.
-This can be a string to set the keyword to use. When t, Org-mode will
+This can be a string to set the keyword to use. When non-nil, Org will
use the first keyword in its list that means done."
:group 'org-archive
:type '(choice
@@ -159,21 +160,24 @@ archive file is."
(defun org-all-archive-files ()
"Get a list of all archive files used in the current buffer."
- (let (file files)
- (save-excursion
- (save-restriction
- (goto-char (point-min))
- (while (re-search-forward
- "^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)"
- nil t)
- (setq file (org-extract-archive-file
- (org-match-string-no-properties 2)))
- (and file (> (length file) 0) (file-exists-p file)
- (add-to-list 'files file)))))
+ (let ((case-fold-search t)
+ files)
+ (org-with-wide-buffer
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)"
+ nil t)
+ (when (save-match-data
+ (if (eq (match-string 1) ":") (org-at-property-p)
+ (eq (org-element-type (org-element-at-point)) 'keyword)))
+ (let ((file (org-extract-archive-file
+ (match-string-no-properties 2))))
+ (when (and (org-string-nw-p file) (file-exists-p file))
+ (push file files))))))
(setq files (nreverse files))
- (setq file (org-extract-archive-file))
- (and file (> (length file) 0) (file-exists-p file)
- (add-to-list 'files file))
+ (let ((file (org-extract-archive-file)))
+ (when (and (org-string-nw-p file) (file-exists-p file))
+ (push file files)))
files))
(defun org-extract-archive-file (&optional location)
@@ -226,42 +230,30 @@ this heading."
((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)
- (tr-org-todo-kwd-alist org-todo-kwd-alist)
- (tr-org-done-keywords org-done-keywords)
- (tr-org-todo-regexp org-todo-regexp)
- (tr-org-todo-line-regexp org-todo-line-regexp)
- (tr-org-odd-levels-only org-odd-levels-only)
- (this-buffer (current-buffer))
- ;; start of variables that will be used for saving context
- ;; The compiler complains about them - keep them anyway!
- (file (abbreviate-file-name
- (or (buffer-file-name (buffer-base-buffer))
- (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)))
- 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
- datetree-date datetree-subheading-p)
-
- ;; Find the local archive location
- (setq location (org-get-local-archive-location)
- afile (org-extract-archive-file location)
- heading (org-extract-archive-heading location)
- infile-p (equal file (abbreviate-file-name (or afile ""))))
- (unless afile
- (error "Invalid `org-archive-location'"))
-
- (if (> (length afile) 0)
- (setq newfile-p (not (file-exists-p afile))
- visiting (find-buffer-visiting afile)
- buffer (or visiting (find-file-noselect afile)))
- (setq buffer (current-buffer)))
- (unless buffer
- (error "Cannot access file \"%s\"" afile))
+ (let* ((tr-org-todo-keywords-1 org-todo-keywords-1)
+ (tr-org-todo-kwd-alist org-todo-kwd-alist)
+ (tr-org-done-keywords org-done-keywords)
+ (tr-org-todo-regexp org-todo-regexp)
+ (tr-org-todo-line-regexp org-todo-line-regexp)
+ (tr-org-odd-levels-only org-odd-levels-only)
+ (this-buffer (current-buffer))
+ (time (format-time-string
+ (substring (cdr org-time-stamp-formats) 1 -1)))
+ (file (abbreviate-file-name
+ (or (buffer-file-name (buffer-base-buffer))
+ (error "No file associated to buffer"))))
+ (location (org-get-local-archive-location))
+ (afile (or (org-extract-archive-file location)
+ (error "Invalid `org-archive-location'")))
+ (heading (org-extract-archive-heading location))
+ (infile-p (equal file (abbreviate-file-name (or afile ""))))
+ (newfile-p (and (org-string-nw-p afile)
+ (not (file-exists-p afile))))
+ (buffer (cond ((not (org-string-nw-p afile)) this-buffer)
+ ((find-buffer-visiting afile))
+ ((find-file-noselect afile))
+ (t (error "Cannot access file \"%s\"" afile))))
+ level datetree-date datetree-subheading-p)
(when (string-match "\\`datetree/" heading)
;; Replace with ***, to represent the 3 levels of headings the
;; datetree has.
@@ -275,106 +267,115 @@ this heading."
(setq heading nil level 0))
(save-excursion
(org-back-to-heading t)
- ;; Get context information that will be lost by moving the tree
- (setq category (org-get-category nil 'force-refresh)
- todo (and (looking-at org-todo-line-regexp)
- (match-string 2))
- priority (org-get-priority
- (if (match-end 3) (match-string 3) ""))
- ltags (org-get-tags)
- itags (org-delete-all ltags (org-get-tags-at))
- atags (org-get-tags-at))
- (setq ltags (mapconcat 'identity ltags " ")
- itags (mapconcat 'identity itags " "))
- ;; We first only copy, in case something goes wrong
- ;; we need to protect `this-command', to avoid kill-region sets it,
- ;; which would lead to duplication of subtrees
- (let (this-command) (org-copy-subtree 1 nil t))
- (set-buffer buffer)
- ;; Enforce org-mode for the archive buffer
- (if (not (derived-mode-p 'org-mode))
- ;; Force the mode for future visits.
- (let ((org-insert-mode-line-in-empty-file t)
- (org-inhibit-startup t))
- (call-interactively 'org-mode)))
- (when (and newfile-p org-archive-file-header-format)
- (goto-char (point-max))
- (insert (format org-archive-file-header-format
- (buffer-file-name this-buffer))))
- (when datetree-date
- (require 'org-datetree)
- (org-datetree-find-date-create datetree-date)
- (org-narrow-to-subtree))
- ;; Force the TODO keywords of the original buffer
- (let ((org-todo-line-regexp tr-org-todo-line-regexp)
- (org-todo-keywords-1 tr-org-todo-keywords-1)
- (org-todo-kwd-alist tr-org-todo-kwd-alist)
- (org-done-keywords tr-org-done-keywords)
- (org-todo-regexp tr-org-todo-regexp)
- (org-todo-line-regexp tr-org-todo-line-regexp)
- (org-odd-levels-only
- (if (local-variable-p 'org-odd-levels-only (current-buffer))
- org-odd-levels-only
- tr-org-odd-levels-only)))
- (goto-char (point-min))
- (outline-show-all)
- (if (and heading (not (and datetree-date (not datetree-subheading-p))))
- (progn
- (if (re-search-forward
- (concat "^" (regexp-quote heading)
- (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)"))
- nil t)
- (goto-char (match-end 0))
- ;; Heading not found, just insert it at the end
- (goto-char (point-max))
- (or (bolp) (insert "\n"))
- ;; datetrees don't need too much spacing
- (insert (if datetree-date "" "\n") heading "\n")
- (end-of-line 0))
- ;; Make the subtree visible
- (outline-show-subtree)
- (if org-archive-reversed-order
- (progn
- (org-back-to-heading t)
- (outline-next-heading))
- (org-end-of-subtree t))
- (skip-chars-backward " \t\r\n")
- (and (looking-at "[ \t\r\n]*")
- ;; datetree archives don't need so much spacing.
- (replace-match (if datetree-date "\n" "\n\n"))))
- ;; No specific heading, just go to end of file.
- (goto-char (point-max)) (unless datetree-date (insert "\n")))
- ;; Paste
- (org-paste-subtree (org-get-valid-level level (and heading 1)))
- ;; Shall we append inherited tags?
- (and itags
- (or (and (eq org-archive-subtree-add-inherited-tags 'infile)
- infile-p)
- (eq org-archive-subtree-add-inherited-tags t))
- (org-set-tags-to atags))
- ;; Mark the entry as done
- (when (and org-archive-mark-done
- (looking-at org-todo-line-regexp)
- (or (not (match-end 2))
- (not (member (match-string 2) org-done-keywords))))
- (let (org-log-done org-todo-log-states)
- (org-todo
- (car (or (member org-archive-mark-done org-done-keywords)
- org-done-keywords)))))
-
- ;; Add the context info
- (when org-archive-save-context-info
- (let ((l org-archive-save-context-info) e n v)
- (while (setq e (pop l))
- (when (and (setq v (symbol-value e))
- (stringp v) (string-match "\\S-" v))
- (setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
- (org-entry-put (point) n v)))))
-
- (widen)
- ;; Save and kill the buffer, if it is not the same buffer.
- (when (not (eq this-buffer buffer))
- (save-buffer))))
+ ;; Get context information that will be lost by moving the
+ ;; tree. See `org-archive-save-context-info'.
+ (let* ((all-tags (org-get-tags-at))
+ (local-tags (org-get-tags))
+ (inherited-tags (org-delete-all local-tags all-tags))
+ (context
+ `((category . ,(org-get-category nil 'force-refresh))
+ (file . ,file)
+ (itags . ,(mapconcat #'identity inherited-tags " "))
+ (ltags . ,(mapconcat #'identity local-tags " "))
+ (olpath . ,(mapconcat #'identity
+ (org-get-outline-path)
+ "/"))
+ (time . ,time)
+ (todo . ,(org-entry-get (point) "TODO")))))
+ ;; We first only copy, in case something goes wrong
+ ;; we need to protect `this-command', to avoid kill-region sets it,
+ ;; which would lead to duplication of subtrees
+ (let (this-command) (org-copy-subtree 1 nil t))
+ (set-buffer buffer)
+ ;; Enforce Org mode for the archive buffer
+ (if (not (derived-mode-p 'org-mode))
+ ;; Force the mode for future visits.
+ (let ((org-insert-mode-line-in-empty-file t)
+ (org-inhibit-startup t))
+ (call-interactively 'org-mode)))
+ (when (and newfile-p org-archive-file-header-format)
+ (goto-char (point-max))
+ (insert (format org-archive-file-header-format
+ (buffer-file-name this-buffer))))
+ (when datetree-date
+ (require 'org-datetree)
+ (org-datetree-find-date-create datetree-date)
+ (org-narrow-to-subtree))
+ ;; Force the TODO keywords of the original buffer
+ (let ((org-todo-line-regexp tr-org-todo-line-regexp)
+ (org-todo-keywords-1 tr-org-todo-keywords-1)
+ (org-todo-kwd-alist tr-org-todo-kwd-alist)
+ (org-done-keywords tr-org-done-keywords)
+ (org-todo-regexp tr-org-todo-regexp)
+ (org-todo-line-regexp tr-org-todo-line-regexp)
+ (org-odd-levels-only
+ (if (local-variable-p 'org-odd-levels-only (current-buffer))
+ org-odd-levels-only
+ tr-org-odd-levels-only)))
+ (goto-char (point-min))
+ (outline-show-all)
+ (if (and heading (not (and datetree-date (not datetree-subheading-p))))
+ (progn
+ (if (re-search-forward
+ (concat "^" (regexp-quote heading)
+ "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)")
+ nil t)
+ (goto-char (match-end 0))
+ ;; Heading not found, just insert it at the end
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))
+ ;; datetrees don't need too much spacing
+ (insert (if datetree-date "" "\n") heading "\n")
+ (end-of-line 0))
+ ;; Make the subtree visible
+ (outline-show-subtree)
+ (if org-archive-reversed-order
+ (progn
+ (org-back-to-heading t)
+ (outline-next-heading))
+ (org-end-of-subtree t))
+ (skip-chars-backward " \t\r\n")
+ (and (looking-at "[ \t\r\n]*")
+ ;; datetree archives don't need so much spacing.
+ (replace-match (if datetree-date "\n" "\n\n"))))
+ ;; No specific heading, just go to end of file.
+ (goto-char (point-max))
+ ;; Subtree narrowing can let the buffer end on
+ ;; a headline. `org-paste-subtree' then deletes it.
+ ;; To prevent this, make sure visible part of buffer
+ ;; always terminates on a new line, while limiting
+ ;; number of blank lines in a date tree.
+ (unless (and datetree-date (bolp)) (insert "\n")))
+ ;; Paste
+ (org-paste-subtree (org-get-valid-level level (and heading 1)))
+ ;; Shall we append inherited tags?
+ (and inherited-tags
+ (or (and (eq org-archive-subtree-add-inherited-tags 'infile)
+ infile-p)
+ (eq org-archive-subtree-add-inherited-tags t))
+ (org-set-tags-to all-tags))
+ ;; Mark the entry as done
+ (when (and org-archive-mark-done
+ (looking-at org-todo-line-regexp)
+ (or (not (match-end 2))
+ (not (member (match-string 2) org-done-keywords))))
+ (let (org-log-done org-todo-log-states)
+ (org-todo
+ (car (or (member org-archive-mark-done org-done-keywords)
+ org-done-keywords)))))
+
+ ;; Add the context info.
+ (dolist (item org-archive-save-context-info)
+ (let ((value (cdr (assq item context))))
+ (when (org-string-nw-p value)
+ (org-entry-put
+ (point)
+ (concat "ARCHIVE_" (upcase (symbol-name item)))
+ value))))
+ (widen)
+ ;; Save and kill the buffer, if it is not the same
+ ;; buffer.
+ (unless (eq this-buffer buffer) (save-buffer)))))
;; Here we are back in the original buffer. Everything seems
;; to have worked. So now run hooks, cut the tree and finish
;; up.
@@ -467,7 +468,7 @@ 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)
+ (lambda (_beg end)
(unless (re-search-forward org-not-done-heading-regexp end t)
"no open TODO items"))
tag))
@@ -478,7 +479,7 @@ 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)
+ (lambda (_beg end)
(let (ts)
(and (re-search-forward org-ts-regexp end t)
(setq ts (match-string 0))
diff --git a/lisp/org-attach.el b/lisp/org-attach.el
index e237b2c..d6e587d 100644
--- a/lisp/org-attach.el
+++ b/lisp/org-attach.el
@@ -1,4 +1,4 @@
-;;; org-attach.el --- Manage file attachments to org-mode tasks
+;;; org-attach.el --- Manage file attachments to Org tasks -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
@@ -22,7 +22,7 @@
;;; Commentary:
-;; See the Org-mode manual for information on how to use it.
+;; See the Org manual for information on how to use it.
;;
;; Attachments are managed in a special directory called "data", which
;; lives in the same directory as the org file itself. If this data
@@ -37,14 +37,13 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
-(require 'org-id)
+(require 'cl-lib)
(require 'org)
+(require 'org-id)
(require 'vc-git)
(defgroup org-attach nil
- "Options concerning entry attachments in Org-mode."
+ "Options concerning entry attachments in Org mode."
:tag "Org Attach"
:group 'org)
@@ -55,6 +54,14 @@ where the Org file lives."
:group 'org-attach
:type 'directory)
+(defcustom org-attach-commit t
+ "If non-nil commit attachments with git.
+This is only done if the Org file is in a git repository."
+ :group 'org-attach
+ :type 'boolean
+ :version "25.2"
+ :package-version '(Org . "9.0"))
+
(defcustom org-attach-git-annex-cutoff (* 32 1024)
"If non-nil, files larger than this will be annexed instead of stored."
:group 'org-attach
@@ -124,13 +131,24 @@ lns create a symbol link. Note that this is not supported
"Non-nil means attachments are deleted upon archiving a subtree.
When set to `query', ask the user instead."
:group 'org-attach
- :version "25.1"
+ :version "25.2"
: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)))
+(defcustom org-attach-annex-auto-get 'ask
+ "Confirmation preference for automatically getting annex files.
+If \\='ask, prompt using `y-or-n-p'. If t, always get. If nil, never get."
+ :group 'org-attach
+ :package-version '(Org . "9")
+ :version "25.2"
+ :type '(choice
+ (const :tag "confirm with `y-or-n-p'" ask)
+ (const :tag "always get from annex if necessary" t)
+ (const :tag "never get from annex" nil)))
+
;;;###autoload
(defun org-attach ()
"The dispatcher for attachment commands.
@@ -208,25 +226,23 @@ using the entry ID will be invoked to access the unique directory for the
current entry.
If the directory does not exist and CREATE-IF-NOT-EXISTS-P is non-nil,
the directory and (if necessary) the corresponding ID will be created."
- (let (attach-dir uuid inherit)
+ (let (attach-dir uuid)
(setq org-attach-inherited (org-entry-get nil "ATTACH_DIR_INHERIT"))
(cond
((setq attach-dir (org-entry-get nil "ATTACH_DIR"))
(org-attach-check-absolute-path attach-dir))
((and org-attach-allow-inheritance
- (setq inherit (org-entry-get nil "ATTACH_DIR_INHERIT" t)))
+ (org-entry-get nil "ATTACH_DIR_INHERIT" t))
(setq attach-dir
- (save-excursion
- (save-restriction
- (widen)
- (if (marker-position org-entry-property-inherited-from)
- (goto-char org-entry-property-inherited-from)
- (org-back-to-heading t))
- (let (org-attach-allow-inheritance)
- (org-attach-dir create-if-not-exists-p)))))
+ (org-with-wide-buffer
+ (if (marker-position org-entry-property-inherited-from)
+ (goto-char org-entry-property-inherited-from)
+ (org-back-to-heading t))
+ (let (org-attach-allow-inheritance)
+ (org-attach-dir create-if-not-exists-p))))
(org-attach-check-absolute-path attach-dir)
(setq org-attach-inherited t))
- (t ; use the ID
+ (t ; use the ID
(org-attach-check-absolute-path nil)
(setq uuid (org-id-get (point) create-if-not-exists-p))
(when (or uuid create-if-not-exists-p)
@@ -272,34 +288,59 @@ the ATTACH_DIR property) their own attachment directory."
(org-entry-put nil "ATTACH_DIR_INHERIT" "t")
(message "Children will inherit attachment directory"))
+(defun org-attach-use-annex ()
+ "Return non-nil if git annex can be used."
+ (let ((git-dir (vc-git-root (expand-file-name org-attach-directory))))
+ (and org-attach-git-annex-cutoff
+ (or (file-exists-p (expand-file-name "annex" git-dir))
+ (file-exists-p (expand-file-name ".git/annex" git-dir))))))
+
+(defun org-attach-annex-get-maybe (path)
+ "Call git annex get PATH (via shell) if using git annex.
+Signals an error if the file content is not available and it was not retrieved."
+ (let ((path-relative (file-relative-name path)))
+ (when (and (org-attach-use-annex)
+ (not
+ (string-equal
+ "found"
+ (shell-command-to-string
+ (format "git annex find --format=found --in=here %s"
+ (shell-quote-argument path-relative))))))
+ (let ((should-get
+ (if (eq org-attach-annex-auto-get 'ask)
+ (y-or-n-p (format "Run git annex get %s? " path-relative))
+ org-attach-annex-auto-get)))
+ (if should-get
+ (progn (message "Running git annex get \"%s\"." path-relative)
+ (call-process "git" nil nil nil "annex" "get" path-relative))
+ (error "File %s stored in git annex but it is not available, and was not retrieved"
+ path))))))
+
(defun org-attach-commit ()
"Commit changes to git if `org-attach-directory' is properly initialized.
This checks for the existence of a \".git\" directory in that directory."
(let* ((dir (expand-file-name org-attach-directory))
(git-dir (vc-git-root dir))
+ (use-annex (org-attach-use-annex))
(changes 0))
(when (and git-dir (executable-find "git"))
(with-temp-buffer
(cd dir)
- (let ((have-annex
- (and org-attach-git-annex-cutoff
- (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
- "git ls-files -zmo --exclude-standard") "\0" t))
- (if (and have-annex
- (>= (nth 7 (file-attributes new-or-modified))
- org-attach-git-annex-cutoff))
- (call-process "git" nil nil nil "annex" "add" new-or-modified)
- (call-process "git" nil nil nil "add" new-or-modified))
- (incf changes)))
+ (dolist (new-or-modified
+ (split-string
+ (shell-command-to-string
+ "git ls-files -zmo --exclude-standard") "\0" t))
+ (if (and use-annex
+ (>= (nth 7 (file-attributes new-or-modified))
+ org-attach-git-annex-cutoff))
+ (call-process "git" nil nil nil "annex" "add" new-or-modified)
+ (call-process "git" nil nil nil "add" new-or-modified))
+ (cl-incf changes))
(dolist (deleted
(split-string
(shell-command-to-string "git ls-files -z --deleted") "\0" t))
(call-process "git" nil nil nil "rm" deleted)
- (incf changes))
+ (cl-incf changes))
(when (> changes 0)
(shell-command "git commit -m 'Synchronized attachments'"))))))
@@ -340,7 +381,8 @@ METHOD may be `cp', `mv', `ln', or `lns' default taken from
((eq method 'cp) (copy-file file fname))
((eq method 'ln) (add-name-to-file file fname))
((eq method 'lns) (make-symbolic-link file fname)))
- (org-attach-commit)
+ (when org-attach-commit
+ (org-attach-commit))
(org-attach-tag)
(cond ((eq org-attach-store-link-p 'attached)
(org-attach-store-link fname))
@@ -390,7 +432,7 @@ The attachment is created as an Emacs buffer."
(let* ((attach-dir (org-attach-dir t))
(files (org-attach-file-list attach-dir))
(file (or file
- (org-icompleting-read
+ (completing-read
"Delete attachment: "
(mapcar (lambda (f)
(list (file-name-nondirectory f)))
@@ -466,9 +508,11 @@ If IN-EMACS is non-nil, force opening in Emacs."
(files (org-attach-file-list attach-dir))
(file (if (= (length files) 1)
(car files)
- (org-icompleting-read "Open attachment: "
- (mapcar 'list files) nil t))))
- (org-open-file (expand-file-name file attach-dir) in-emacs)))
+ (completing-read "Open attachment: "
+ (mapcar #'list files) nil t)))
+ (path (expand-file-name file attach-dir)))
+ (org-attach-annex-get-maybe path)
+ (org-open-file path in-emacs)))
(defun org-attach-open-in-emacs ()
"Open attachment, force opening in Emacs.
diff --git a/lisp/org-bbdb.el b/lisp/org-bbdb.el
index aeee35f..dd9ef26 100644
--- a/lisp/org-bbdb.el
+++ b/lisp/org-bbdb.el
@@ -1,4 +1,4 @@
-;;; org-bbdb.el --- Support for links to BBDB entries from within Org-mode
+;;; org-bbdb.el --- Support for links to BBDB entries -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2016 Free Software Foundation, Inc.
@@ -25,12 +25,12 @@
;;
;;; Commentary:
-;; This file implements links to BBDB database entries from within Org-mode.
-;; Org-mode loads this module by default - if this is not what you want,
+;; This file implements links to BBDB database entries from within Org.
+;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;; It also implements an interface (based on Ivar Rummelhoff's
-;; bbdb-anniv.el) for those org-mode users, who do not use the diary
+;; bbdb-anniv.el) for those Org users, who do not use the diary
;; but who do want to include the anniversaries stored in the BBDB
;; into the org-agenda. If you already include the `diary' into the
;; agenda, you might want to prefer to include the anniversaries in
@@ -94,8 +94,7 @@
;;; Code:
(require 'org)
-(eval-when-compile
- (require 'cl))
+(require 'cl-lib)
;; Declare external functions and variables
@@ -106,6 +105,7 @@
(declare-function bbdb-name "ext:bbdb-com" (string elidep))
(declare-function bbdb-completing-read-record "ext:bbdb-com"
(prompt &optional omit-records))
+(declare-function bbdb-record-field "ext:bbdb" (recond field))
(declare-function bbdb-record-getprop "ext:bbdb" (record property))
(declare-function bbdb-record-name "ext:bbdb" (record))
(declare-function bbdb-records "ext:bbdb"
@@ -124,7 +124,7 @@
(declare-function calendar-leap-year-p "calendar" (year))
(declare-function diary-ordinal-suffix "diary-lib" (n))
-(org-no-warnings (defvar date)) ;; unprefixed, from calendar.el
+(with-no-warnings (defvar date)) ;; unprefixed, from calendar.el
;; Customization
@@ -194,10 +194,12 @@ date year)."
:group 'org-bbdb-anniversaries
:require 'bbdb)
-
;; Install the link type
-(org-add-link-type "bbdb" 'org-bbdb-open 'org-bbdb-export)
-(add-hook 'org-store-link-functions 'org-bbdb-store-link)
+(org-link-set-parameters "bbdb"
+ :follow #'org-bbdb-open
+ :export #'org-bbdb-export
+ :complete #'org-bbdb-complete-link
+ :store #'org-bbdb-store-link)
;; Implementation
(defun org-bbdb-store-link ()
@@ -208,7 +210,7 @@ date year)."
(name (bbdb-record-name rec))
(company (if (fboundp 'bbdb-record-getprop)
(bbdb-record-getprop rec 'company)
- (car (bbdb-record-get-field rec 'organization))))
+ (car (bbdb-record-field rec 'organization))))
(link (concat "bbdb:" name)))
(org-store-link-props :type "bbdb" :name name :company company
:link link :description name)
@@ -230,10 +232,9 @@ italicized, in all other cases it is left unchanged."
(defun org-bbdb-open (name)
"Follow a BBDB link to NAME."
(require 'bbdb-com)
- (let ((inhibit-redisplay (not debug-on-error))
- (bbdb-electric-p nil))
+ (let ((inhibit-redisplay (not debug-on-error)))
(if (fboundp 'bbdb-name)
- (org-bbdb-open-old name)
+ (org-bbdb-open-old name)
(org-bbdb-open-new name))))
(defun org-bbdb-open-old (name)
@@ -280,14 +281,11 @@ italicized, in all other cases it is left unchanged."
"Convert YYYY-MM-DD to (month date year).
Argument TIME-STR is the value retrieved from BBDB. If YYYY- is omitted
it will be considered unknown."
- (multiple-value-bind (a b c) (values-list (org-split-string time-str "-"))
- (if (eq c nil)
- (list (string-to-number a)
- (string-to-number b)
- nil)
- (list (string-to-number b)
- (string-to-number c)
- (string-to-number a)))))
+ (pcase (org-split-string time-str "-")
+ (`(,a ,b nil) (list (string-to-number a) (string-to-number b) nil))
+ (`(,a ,b ,c) (list (string-to-number b)
+ (string-to-number c)
+ (string-to-number a)))))
(defun org-bbdb-anniv-split (str)
"Split multiple entries in the BBDB anniversary field.
@@ -325,9 +323,9 @@ The anniversaries are assumed to be stored `org-bbdb-anniversary-field'."
(bbdb-split "\n" annivs)))
(while annivs
(setq split (org-bbdb-anniv-split (pop annivs)))
- (multiple-value-bind (m d y)
- (values-list (funcall org-bbdb-extract-date-fun (car split)))
- (setq tmp (gethash (list m d) org-bbdb-anniv-hash))
+ (pcase-let ((`(,m ,d ,y) (funcall org-bbdb-extract-date-fun
+ (car split))))
+ (setq tmp (gethash (list m d) org-bbdb-anniv-hash))
(puthash (list m d) (cons (list y
(bbdb-record-name rec)
(cadr split))
@@ -335,7 +333,7 @@ The anniversaries are assumed to be stored `org-bbdb-anniversary-field'."
org-bbdb-anniv-hash))))))
(setq org-bbdb-updated-p nil))
-(defun org-bbdb-updated (rec)
+(defun org-bbdb-updated (_rec)
"Record the fact that BBDB has been updated.
This is used by Org to re-create the anniversary hash table."
(setq org-bbdb-updated-p t))
@@ -397,6 +395,66 @@ This is used by Org to re-create the anniversary hash table."
))
text))
+;;; Return list of anniversaries for today and the next n-1 (default: n=7) days.
+;;; This is meant to be used in an org file instead of org-bbdb-anniversaries:
+;;;
+;;; %%(org-bbdb-anniversaries-future)
+;;;
+;;; or
+;;;
+;;; %%(org-bbdb-anniversaries-future 3)
+;;;
+;;; to override the 7-day default.
+
+(defun org-bbdb-date-list (d n)
+ "Return a list of dates in (m d y) format from the given date D to n-1 days hence."
+ (let ((abs (calendar-absolute-from-gregorian d)))
+ (mapcar (lambda (i) (calendar-gregorian-from-absolute (+ abs i)))
+ (number-sequence 0 (1- n)))))
+
+;;;###autoload
+(defun org-bbdb-anniversaries-future (&optional n)
+ "Return list of anniversaries for today and the next n-1 days (default n=7)."
+ (let ((n (or n 7)))
+ (when (<= n 0)
+ (error "The (optional) argument of `org-bbdb-anniversaries-future' \
+must be positive"))
+ (let (
+ ;; List of relevant dates.
+ (dates (org-bbdb-date-list date n))
+ ;; Function to annotate text of each element of l with the
+ ;; anniversary date d.
+ (annotate-descriptions
+ (lambda (d l)
+ (mapcar (lambda (x)
+ ;; The assumption here is that x is a bbdb link
+ ;; of the form [[bbdb:name][description]].
+ ;; This function rather arbitrarily modifies
+ ;; the description by adding the date to it in
+ ;; a fixed format.
+ (string-match "]]" x)
+ (replace-match (format " -- %d-%02d-%02d\\&"
+ (nth 2 d)
+ (nth 0 d)
+ (nth 1 d))
+ nil nil x))
+ l))))
+ ;; Map a function that generates anniversaries for each date
+ ;; over the dates and nconc the results into a single list. When
+ ;; it is no longer necessary to support older versions of Emacs,
+ ;; this can be done with a cl-mapcan; for now, we use the (apply
+ ;; #'nconc ...) method for compatibility.
+ (apply #'nconc
+ (mapcar
+ (lambda (d)
+ (let ((date d))
+ ;; Rebind 'date' so that org-bbdb-anniversaries will
+ ;; be fooled into giving us the list for the given
+ ;; date and then annotate the descriptions for that
+ ;; date.
+ (funcall annotate-descriptions d (org-bbdb-anniversaries))))
+ dates)))))
+
(defun org-bbdb-complete-link ()
"Read a bbdb link with name completion."
(require 'bbdb-com)
diff --git a/lisp/org-bibtex.el b/lisp/org-bibtex.el
index a1cd8b0..db5d97b 100644
--- a/lisp/org-bibtex.el
+++ b/lisp/org-bibtex.el
@@ -1,4 +1,4 @@
-;;; org-bibtex.el --- Org links to BibTeX entries
+;;; org-bibtex.el --- Org links to BibTeX entries -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2007-2016 Free Software Foundation, Inc.
;;
@@ -73,7 +73,7 @@
;; =====================================================================
;;
;; Additionally, the following functions are now available for storing
-;; bibtex entries within Org-mode documents.
+;; bibtex entries within Org documents.
;;
;; - Run `org-bibtex' to export the current file to a .bib.
;;
@@ -92,27 +92,28 @@
;;
;;; History:
;;
-;; The link creation part has been part of Org-mode for a long time.
+;; The link creation part has been part of Org for a long time.
;;
;; Creating better capture template information was inspired by a request
;; of Austin Frank: http://article.gmane.org/gmane.emacs.orgmode/4112
;; and then implemented by Bastien Guerry.
;;
;; Eric Schulte eventually added the functions for translating between
-;; Org-mode headlines and Bibtex entries, and for fleshing out the Bibtex
-;; fields of existing Org-mode headlines.
+;; Org headlines and Bibtex entries, and for fleshing out the Bibtex
+;; fields of existing Org headlines.
;;
-;; Org-mode loads this module by default - if this is not what you want,
+;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
(require 'org)
(require 'bibtex)
-(eval-when-compile
- (require 'cl))
+(require 'cl-lib)
(require 'org-compat)
+(defvar org-agenda-overriding-header)
+(defvar org-agenda-search-view-always-boolean)
(defvar org-bibtex-description nil) ; dynamically scoped from org.el
(defvar org-id-locations)
@@ -120,7 +121,6 @@
(declare-function bibtex-generate-autokey "bibtex" ())
(declare-function bibtex-parse-entry "bibtex" (&optional content))
(declare-function bibtex-url "bibtex" (&optional pos no-browse))
-(declare-function org-babel-trim "ob" (string &optional regexp))
;;; Bibtex data
@@ -293,7 +293,7 @@ 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"
+ :version "25.2"
:package-version '(Org . "8.3")
:type 'boolean)
@@ -312,7 +312,7 @@ and `org-exclude-tags-from-inheritence'."
(org-entry-get (point) (upcase property))
(org-entry-get (point) (concat org-bibtex-prefix
(upcase property)))))))
- (when it (org-babel-trim it))))
+ (when it (org-trim it))))
(defun org-bibtex-put (property value)
(let ((prop (upcase (if (keywordp property)
@@ -325,29 +325,27 @@ and `org-exclude-tags-from-inheritence'."
(defun org-bibtex-headline ()
"Return a bibtex entry of the given headline as a string."
- (let* ((val (lambda (key lst) (cdr (assoc key lst))))
- (to (lambda (string) (intern (concat ":" string))))
- (from (lambda (key) (substring (symbol-name key) 1)))
- flatten ; silent compiler warning
- (flatten (lambda (&rest lsts)
- (apply #'append (mapcar
- (lambda (e)
- (if (listp e) (apply flatten e) (list e)))
- lsts))))
- (notes (buffer-string))
- (id (org-bibtex-get org-bibtex-key-property))
- (type (org-bibtex-get org-bibtex-type-property-name))
- (tags (when org-bibtex-tags-are-keywords
- (delq nil
- (mapcar
- (lambda (tag)
- (unless (member tag
- (append org-bibtex-tags
- org-bibtex-no-export-tags))
- tag))
- (if org-bibtex-inherit-tags
- (org-get-tags-at)
- (org-get-local-tags-at)))))))
+ (letrec ((val (lambda (key lst) (cdr (assoc key lst))))
+ (to (lambda (string) (intern (concat ":" string))))
+ (from (lambda (key) (substring (symbol-name key) 1)))
+ (flatten (lambda (&rest lsts)
+ (apply #'append (mapcar
+ (lambda (e)
+ (if (listp e) (apply flatten e) (list e)))
+ lsts))))
+ (id (org-bibtex-get org-bibtex-key-property))
+ (type (org-bibtex-get org-bibtex-type-property-name))
+ (tags (when org-bibtex-tags-are-keywords
+ (delq nil
+ (mapcar
+ (lambda (tag)
+ (unless (member tag
+ (append org-bibtex-tags
+ org-bibtex-no-export-tags))
+ tag))
+ (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
@@ -373,7 +371,7 @@ and `org-exclude-tags-from-inheritence'."
(mapcar
(lambda (field)
(let ((value (or (org-bibtex-get (funcall from field))
- (and (equal :title field)
+ (and (eq :title field)
(nth 4 (org-heading-components))))))
(when value (cons (funcall from field) value))))
(funcall flatten
@@ -436,13 +434,14 @@ With optional argument OPTIONAL, also prompt for optional fields."
(funcall val :required (funcall val type org-bibtex-types)))
(when optional (funcall val :optional (funcall val type org-bibtex-types)))))
(when (consp field) ; or'd pair of fields e.g., (:editor :author)
- (let ((present (first (remove
+ (let ((present (nth 0 (remove
nil
(mapcar
- (lambda (f) (when (org-bibtex-get (funcall name f)) f))
+ (lambda (f)
+ (when (org-bibtex-get (funcall name f)) f))
field)))))
(setf field (or present (funcall keyword
- (org-icompleting-read
+ (completing-read
"Field: " (mapcar name field)))))))
(let ((name (funcall name field)))
(unless (org-bibtex-get name)
@@ -454,8 +453,9 @@ With optional argument OPTIONAL, also prompt for optional fields."
;;; Bibtex link functions
-(org-add-link-type "bibtex" 'org-bibtex-open)
-(add-hook 'org-store-link-functions 'org-bibtex-store-link)
+(org-link-set-parameters "bibtex"
+ :follow #'org-bibtex-open
+ :store #'org-bibtex-store-link)
(defun org-bibtex-open (path)
"Visit the bibliography entry on PATH."
@@ -548,7 +548,7 @@ With optional argument OPTIONAL, also prompt for optional fields."
(add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex)
-;;; Bibtex <-> Org-mode headline translation functions
+;;; Bibtex <-> Org headline translation functions
(defun org-bibtex (filename)
"Export each headline in the current file to a bibtex entry.
Headlines are exported using `org-bibtex-headline'."
@@ -564,7 +564,7 @@ Headlines are exported using `org-bibtex-headline'."
(let ((bibtex-entries
(remove nil (org-map-entries
(lambda ()
- (condition-case foo
+ (condition-case nil
(org-bibtex-headline)
(error (throw 'bib (point)))))))))
(with-temp-file filename
@@ -595,7 +595,7 @@ With prefix argument OPTIONAL also prompt for optional fields."
With a prefix arg, query for optional fields as well.
If nonew is t, add data to the headline of the entry at point."
(interactive "P")
- (let* ((type (org-icompleting-read
+ (let* ((type (completing-read
"Type: " (mapcar (lambda (type)
(substring (symbol-name (car type)) 1))
org-bibtex-types)
@@ -614,7 +614,7 @@ If nonew is t, add data to the headline of the entry at point."
(org-bibtex-put org-bibtex-type-property-name
(substring (symbol-name type) 1))
(org-bibtex-fleshout type arg)
- (mapc (lambda (tag) (org-toggle-tag tag 'on)) org-bibtex-tags)))
+ (dolist (tag org-bibtex-tags) (org-toggle-tag tag 'on))))
(defun org-bibtex-create-in-current-entry (&optional arg)
"Add bibliographical data to the current entry.
@@ -628,10 +628,10 @@ This uses `bibtex-parse-entry'."
(interactive)
(let ((keyword (lambda (str) (intern (concat ":" (downcase str)))))
(clean-space (lambda (str) (replace-regexp-in-string
- "[[:space:]\n\r]+" " " str)))
+ "[[:space:]\n\r]+" " " str)))
(strip-delim
- (lambda (str) ; strip enclosing "..." and {...}
- (dolist (pair '((34 . 34) (123 . 125) (123 . 125)))
+ (lambda (str) ; strip enclosing "..." and {...}
+ (dolist (pair '((34 . 34) (123 . 125)))
(when (and (> (length str) 1)
(= (aref str 0) (car pair))
(= (aref str (1- (length str))) (cdr pair)))
@@ -639,10 +639,10 @@ This uses `bibtex-parse-entry'."
(push (mapcar
(lambda (pair)
(cons (let ((field (funcall keyword (car pair))))
- (case field
+ (pcase field
(:=type= :type)
(:=key= :key)
- (otherwise field)))
+ (_ field)))
(funcall clean-space (funcall strip-delim (cdr pair)))))
(save-excursion (bibtex-beginning-of-entry) (bibtex-parse-entry)))
org-bibtex-entries)))
@@ -683,25 +683,23 @@ Return the number of saved entries."
(org-bibtex-put org-bibtex-type-property-name
(downcase (funcall val :type)))
(dolist (pair entry)
- (case (car pair)
+ (pcase (car pair)
(:title nil)
(:type nil)
(:key (org-bibtex-put org-bibtex-key-property (cdr pair)))
(:keywords (if org-bibtex-tags-are-keywords
- (mapc
- (lambda (kw)
- (funcall
- togtag
- (replace-regexp-in-string
- "[^[:alnum:]_@#%]" ""
- (replace-regexp-in-string "[ \t]+" "_" kw))))
- (split-string (cdr pair) ", *"))
+ (dolist (kw (split-string (cdr pair) ", *"))
+ (funcall
+ togtag
+ (replace-regexp-in-string
+ "[^[:alnum:]_@#%]" ""
+ (replace-regexp-in-string "[ \t]+" "_" kw))))
(org-bibtex-put (car pair) (cdr pair))))
- (otherwise (org-bibtex-put (car pair) (cdr pair)))))
+ (_ (org-bibtex-put (car pair) (cdr pair)))))
(mapc togtag org-bibtex-tags)))
(defun org-bibtex-yank ()
- "If kill ring holds a bibtex entry yank it as an Org-mode headline."
+ "If kill ring holds a bibtex entry yank it as an Org headline."
(interactive)
(let (entry)
(with-temp-buffer (yank 1) (setf entry (org-bibtex-read)))
@@ -710,7 +708,7 @@ Return the number of saved entries."
(error "Yanked text does not appear to contain a BibTeX entry"))))
(defun org-bibtex-import-from-file (file)
- "Read bibtex entries from FILE and insert as Org-mode headlines after point."
+ "Read bibtex entries from FILE and insert as Org headlines after point."
(interactive "fFile: ")
(dotimes (_ (org-bibtex-read-file file))
(save-excursion (org-bibtex-write))
diff --git a/lisp/org-capture.el b/lisp/org-capture.el
index 5052ad8..ced8399 100644
--- a/lisp/org-capture.el
+++ b/lisp/org-capture.el
@@ -1,4 +1,4 @@
-;;; org-capture.el --- Fast note taking in Org-mode
+;;; org-capture.el --- Fast note taking in Org -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
@@ -47,20 +47,18 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(require 'cl-lib)
(require 'org)
+(declare-function org-at-encrypted-entry-p "org-crypt" ())
(declare-function org-datetree-find-date-create "org-datetree"
(date &optional keep-restriction))
+(declare-function org-decrypt-entry "org-crypt" ())
+(declare-function org-encrypt-entry "org-crypt" ())
(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))
-(declare-function org-at-encrypted-entry-p "org-crypt" ())
-(declare-function org-encrypt-entry "org-crypt" ())
-(declare-function org-decrypt-entry "org-crypt" ())
+(defvar org-end-time-was-given)
(defvar org-remember-default-headline)
(defvar org-remember-templates)
(defvar org-table-hlines)
@@ -77,6 +75,9 @@
;; to indicate that the link properties have already been stored
(defvar org-capture-link-is-already-stored nil)
+(defvar org-capture-is-refiling nil
+ "Non-nil when capture process is refiling an entry.")
+
(defgroup org-capture nil
"Options concerning capturing new entries."
:tag "Org Capture"
@@ -104,9 +105,9 @@ description A short string describing the template, will be shown during
selection.
type The type of entry. Valid types are:
- entry an Org-mode node, with a headline. Will be
- filed as the child of the target entry or as
- a top-level entry.
+ entry an Org node, with a headline. Will be filed
+ as the child of the target entry or as a
+ top-level entry.
item a plain list item, will be placed in the
first plain list at the target
location.
@@ -117,7 +118,7 @@ type The type of entry. Valid types are:
plain text to be inserted as it is.
target Specification of where the captured item should be placed.
- In Org-mode files, targets usually define a node. Entries will
+ In Org files, targets usually define a node. Entries will
become children of this node, other types will be added to the
table or list in the body of this node.
@@ -150,6 +151,12 @@ target Specification of where the captured item should be placed.
(file+datetree+prompt \"path/to/file\")
Will create a heading in a date tree, prompts for date
+ (file+weektree \"path/to/file\")
+ Will create a heading in a week tree for today's date
+
+ (file+weektree+prompt \"path/to/file\")
+ Will create a heading in a week tree, prompts for date
+
(file+function \"path/to/file\" function-finding-location)
A function to find the right location in the file
@@ -157,8 +164,8 @@ target Specification of where the captured item should be placed.
File to the entry that is currently being clocked
(function function-finding-location)
- Most general way, write your own function to find both
- file and location
+ Most general way: write your own function which both visits
+ the file and moves point to the right location
template The template for creating the capture item. If you leave this
empty, an appropriate default template will be used. See below
@@ -220,15 +227,20 @@ properties are:
is finalized.
The template defines the text to be inserted. Often this is an
-org-mode entry (so the first line should start with a star) that
+Org mode entry (so the first line should start with a star) that
will be filed as a child of the target headline. It can also be
freely formatted text. Furthermore, the following %-escapes will
-be replaced with content and expanded in this order:
+be replaced with content and expanded:
- %[pathname] Insert the contents of the file given by `pathname'.
+ %[pathname] Insert the contents of the file given by
+ `pathname'. These placeholders are expanded at the very
+ beginning of the process so they can be used to extend the
+ current template.
%(sexp) Evaluate elisp `(sexp)' and replace it with the results.
- For convenience, %:keyword (see below) placeholders within
- the expression will be expanded prior to this.
+ Only placeholders pre-existing within the template, or
+ introduced with %[pathname] are expanded this way. Since this
+ happens after expanding non-interactive %-escapes, those can
+ be used to fill the expression.
%<...> The result of format-time-string on the ... format specification.
%t Time stamp, date only.
%T Time stamp with date and time.
@@ -257,8 +269,8 @@ be replaced with content and expanded in this order:
A default value and a completion table ca be specified like this:
%^{prompt|default|completion2|completion3|...}.
%? After completing the template, position cursor here.
- %\\n Insert the text entered at the nth %^{prompt}, where `n' is
- a number, starting from 1.
+ %\\1 ... %\\N Insert the text entered at the nth %^{prompt}, where N
+ is a number, starting from 1.
Apart from these general escapes, you can access information specific to
the link type that is created. For example, calling `org-capture' in emails
@@ -276,13 +288,21 @@ gnus | %:from %:fromname %:fromaddress
| %:date %:date-timestamp (as active timestamp)
| %:date-timestamp-inactive (as inactive timestamp)
gnus | %:group, for messages also all email fields
-w3, w3m | %:type %:url
+eww, w3, w3m | %:type %:url
info | %:type %:file %:node
-calendar | %:type %:date"
+calendar | %:type %:date
+
+When you need to insert a literal percent sign in the template,
+you can escape ambiguous cases with a backward slash, e.g., \\%i."
:group 'org-capture
:version "24.1"
:type
- '(repeat
+ (let ((file-variants '(choice :tag "Filename "
+ (file :tag "Literal")
+ (function :tag "Function")
+ (variable :tag "Variable")
+ (sexp :tag "Form"))))
+ `(repeat
(choice :value ("" "" entry (file "~/org/notes.org") "")
(list :tag "Multikey description"
(string :tag "Keys ")
@@ -299,39 +319,45 @@ calendar | %:type %:date"
(choice :tag "Target location"
(list :tag "File"
(const :format "" file)
- (file :tag " File"))
+ ,file-variants)
(list :tag "ID"
(const :format "" id)
(string :tag " ID"))
(list :tag "File & Headline"
(const :format "" file+headline)
- (file :tag " File ")
+ ,file-variants
(string :tag " Headline"))
(list :tag "File & Outline path"
(const :format "" file+olp)
- (file :tag " File ")
+ ,file-variants
(repeat :tag "Outline path" :inline t
(string :tag "Headline")))
(list :tag "File & Regexp"
(const :format "" file+regexp)
- (file :tag " File ")
+ ,file-variants
(regexp :tag " Regexp"))
(list :tag "File & Date tree"
(const :format "" file+datetree)
- (file :tag " File"))
+ ,file-variants)
(list :tag "File & Date tree, prompt for date"
(const :format "" file+datetree+prompt)
- (file :tag " File"))
+ ,file-variants)
+ (list :tag "File & Week tree"
+ (const :format "" file+weektree)
+ ,file-variants)
+ (list :tag "File & Week tree, prompt for date"
+ (const :format "" file+weektree+prompt)
+ ,file-variants)
(list :tag "File & function"
(const :format "" file+function)
- (file :tag " File ")
+ ,file-variants
(sexp :tag " Function"))
(list :tag "Current clocking task"
(const :format "" clock))
(list :tag "Function"
(const :format "" function)
(sexp :tag " Function")))
- (choice :tag "Template"
+ (choice :tag "Template "
(string)
(list :tag "File"
(const :format "" file)
@@ -352,7 +378,7 @@ calendar | %:type %:date"
((const :format "%v " :clock-resume) (const t))
((const :format "%v " :unnarrowed) (const t))
((const :format "%v " :table-line-pos) (const t))
- ((const :format "%v " :kill-buffer) (const t))))))))
+ ((const :format "%v " :kill-buffer) (const t)))))))))
(defcustom org-capture-before-finalize-hook nil
"Hook that is run right before a capture process is finalized.
@@ -423,7 +449,7 @@ to avoid conflicts with other active capture processes."
(defvar org-capture-mode-map (make-sparse-keymap)
"Keymap for `org-capture-mode', a minor mode.
-Use this map to set additional keybindings for when Org-mode is used
+Use this map to set additional keybindings for when Org mode is used
for a capture buffer.")
(defvar org-capture-mode-hook nil
@@ -434,11 +460,12 @@ for a capture buffer.")
Turning on this mode runs the normal hook `org-capture-mode-hook'."
nil " Rem" org-capture-mode-map
- (org-set-local
- 'header-line-format
+ (setq-local
+ header-line-format
(substitute-command-keys
- "\\<org-capture-mode-map>Capture buffer. Finish \\[org-capture-finalize], \
-refile \\[org-capture-refile], abort \\[org-capture-kill].")))
+ "\\<org-capture-mode-map>Capture buffer. Finish \
+`\\[org-capture-finalize]', refile `\\[org-capture-refile]', \
+abort `\\[org-capture-kill]'.")))
(define-key org-capture-mode-map "\C-c\C-c" 'org-capture-finalize)
(define-key org-capture-mode-map "\C-c\C-k" 'org-capture-kill)
(define-key org-capture-mode-map "\C-c\C-w" 'org-capture-refile)
@@ -507,7 +534,8 @@ to avoid duplicates.)"
(defcustom org-capture-use-agenda-date nil
"Non-nil means use the date at point when capturing from agendas.
-When nil, you can still capture using the date at point with \\[org-agenda-capture]."
+When nil, you can still capture using the date at point with
+`\\[org-agenda-capture]'."
:group 'org-capture
:version "24.3"
:type 'boolean)
@@ -516,17 +544,20 @@ When nil, you can still capture using the date at point with \\[org-agenda-captu
(defun org-capture (&optional goto keys)
"Capture something.
\\<org-capture-mode-map>
-This will let you select a template from `org-capture-templates', and then
-file the newly captured information. The text is immediately inserted
-at the target location, and an indirect buffer is shown where you can
-edit it. Pressing \\[org-capture-finalize] brings you back to the previous state
-of Emacs, so that you can continue your work.
-
-When called interactively with a \\[universal-argument] prefix argument GOTO, don't capture
-anything, just go to the file/headline where the selected template
-stores its notes. With a double prefix argument \
-\\[universal-argument] \\[universal-argument], go to the last note
-stored.
+This will let you select a template from `org-capture-templates', and
+then file the newly captured information. The text is immediately
+inserted at the target location, and an indirect buffer is shown where
+you can edit it. Pressing `\\[org-capture-finalize]' brings you back to the \
+previous
+state of Emacs, so that you can continue your work.
+
+When called interactively with a `\\[universal-argument]' prefix argument \
+GOTO, don't
+capture anything, just go to the file/headline where the selected
+template stores its notes.
+
+With a `\\[universal-argument] \\[universal-argument]' prefix argument, go to \
+the last note stored.
When called with a `C-0' (zero) prefix, insert a template at point.
@@ -567,7 +598,7 @@ of the day at point (if any) or the current HH:MM time."
((equal entry "C")
(customize-variable 'org-capture-templates))
((equal entry "q")
- (error "Abort"))
+ (user-error "Abort"))
(t
(org-capture-set-plist entry)
(org-capture-get-template)
@@ -599,10 +630,10 @@ of the day at point (if any) or the current HH:MM time."
(org-capture-insert-template-here)
(condition-case error
(org-capture-place-template
- (equal (car (org-capture-get :target)) 'function))
+ (eq (car (org-capture-get :target)) 'function))
((error quit)
(if (and (buffer-base-buffer (current-buffer))
- (string-match "\\`CAPTURE-" (buffer-name)))
+ (string-prefix-p "CAPTURE-" (buffer-name)))
(kill-buffer (current-buffer)))
(set-window-configuration (org-capture-get :return-to-wconf))
(error "Capture template `%s': %s"
@@ -616,7 +647,7 @@ of the day at point (if any) or the current HH:MM time."
(org-capture-put :interrupted-clock
(copy-marker org-clock-marker)))
(org-clock-in)
- (org-set-local 'org-capture-clock-was-started t))
+ (setq-local org-capture-clock-was-started t))
(error
"Could not start the clock in this capture buffer")))
(if (org-capture-get :immediate-finish)
@@ -649,7 +680,7 @@ captured item after finalizing."
(setq stay-with-capture t))
(unless (and org-capture-mode
(buffer-base-buffer (current-buffer)))
- (error "This does not seem to be a capture buffer for Org-mode"))
+ (error "This does not seem to be a capture buffer for Org mode"))
(run-hooks 'org-capture-prepare-finalize-hook)
@@ -685,7 +716,7 @@ captured item after finalizing."
(m2 (org-capture-get :end-marker 'local)))
(if (and m1 m2 (= m1 beg) (= m2 end))
(progn
- (setq m2 (if (cdr (assoc 'heading org-blank-before-new-entry))
+ (setq m2 (if (cdr (assq 'heading org-blank-before-new-entry))
m2 (1+ m2))
m2 (if (< (point-max) m2) (point-max) m2))
(setq abort-note 'clean)
@@ -773,11 +804,12 @@ captured item after finalizing."
;; Special cases
(cond
(abort-note
- (cond
- ((equal abort-note 'clean)
- (message "Capture process aborted and target buffer cleaned up"))
- ((equal abort-note 'dirty)
- (error "Capture process aborted, but target buffer could not be cleaned up correctly"))))
+ (cl-case abort-note
+ (clean
+ (message "Capture process aborted and target buffer cleaned up"))
+ (dirty
+ (error "Capture process aborted, but target buffer could not be \
+cleaned up correctly"))))
(stay-with-capture
(org-capture-goto-last-stored)))
;; Return if we did store something
@@ -793,17 +825,15 @@ already gone. Any prefix argument will be passed to the refile command."
"Refiling from a capture buffer makes only sense for `entry'-type templates"))
(let ((pos (point))
(base (buffer-base-buffer (current-buffer)))
- (org-refile-for-capture t)
+ (org-capture-is-refiling t)
(kill-buffer (org-capture-get :kill-buffer 'local)))
(org-capture-put :kill-buffer nil)
(org-capture-finalize)
(save-window-excursion
(with-current-buffer (or base (current-buffer))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char pos)
- (call-interactively 'org-refile)))))
+ (org-with-wide-buffer
+ (goto-char pos)
+ (call-interactively 'org-refile))))
(when kill-buffer (kill-buffer base))))
(defun org-capture-kill ()
@@ -899,21 +929,25 @@ Store them in the capture property list."
(setq target-entry-p (and (derived-mode-p 'org-mode) (org-at-heading-p))))
(error "No match for target regexp in file %s" (nth 1 target))))
- ((memq (car target) '(file+datetree file+datetree+prompt))
+ ((memq (car target) '(file+datetree file+datetree+prompt file+weektree file+weektree+prompt))
(require 'org-datetree)
(set-buffer (org-capture-target-buffer (nth 1 target)))
(org-capture-put-target-region-and-position)
(widen)
- ;; Make a date tree entry, with the current date (or yesterday,
- ;; if we are extending dates for a couple of hours)
- (org-datetree-find-date-create
+ ;; Make a date/week tree entry, with the current date (or
+ ;; yesterday, if we are extending dates for a couple of hours)
+ (funcall
+ (cond
+ ((memq (car target) '(file+weektree file+weektree+prompt))
+ #'org-datetree-find-iso-week-create)
+ (t #'org-datetree-find-date-create))
(calendar-gregorian-from-absolute
(cond
(org-overriding-default-time
;; use the overriding default time
(time-to-days org-overriding-default-time))
- ((eq (car target) 'file+datetree+prompt)
+ ((memq (car target) '(file+datetree+prompt file+weektree+prompt))
;; prompt for date
(let ((prompt-time (org-read-date
nil t nil "Date for tree entry:"
@@ -924,7 +958,9 @@ Store them in the capture property list."
(not org-time-was-given))
(not (= (time-to-days prompt-time) (org-today))))
;; Use 00:00 when no time is given for another date than today?
- (apply 'encode-time (append '(0 0 0) (cdddr (decode-time prompt-time)))))
+ (apply #'encode-time
+ (append '(0 0 0)
+ (cl-cdddr (decode-time prompt-time)))))
((string-match "\\([^ ]+\\)--?[^ ]+[ ]+\\(.*\\)" org-read-date-final-answer)
;; Replace any time range by its start
(apply 'encode-time
@@ -972,16 +1008,13 @@ 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. When it is
-a string, return it. However, if it is the empty string, return
-`org-default-notes-file' instead."
+When FILE is a function, call it. When it is a variable,
+retrieve its value. When it is the empty string, return
+`org-default-notes-file'. In any other case, return FILE as-is."
(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))
- ((consp file) (eval file))
(t file)))
(defun org-capture-target-buffer (file)
@@ -994,12 +1027,6 @@ a string, return it. However, if it is the empty string, return
(progn (org-capture-put :new-buffer t)
(find-file-noselect (expand-file-name file org-directory)))))
-(defun org-capture-steal-local-variables (buffer)
- "Install Org-mode local variables of BUFFER."
- (mapc (lambda (v)
- (ignore-errors (org-set-local (car v) (cdr v))))
- (buffer-local-variables buffer)))
-
(defun org-capture-place-template (&optional inhibit-wconf-store)
"Insert the template at the target location, and display the buffer.
When `inhibit-wconf-store', don't store the window configuration, as it
@@ -1012,32 +1039,29 @@ may have been stored before."
(widen)
(outline-show-all)
(goto-char (org-capture-get :pos))
- (org-set-local 'org-capture-target-marker
- (point-marker))
- (org-set-local 'outline-level 'org-outline-level)
- (let* ((template (org-capture-get :template))
- (type (org-capture-get :type)))
- (case type
- ((nil entry) (org-capture-place-entry))
- (table-line (org-capture-place-table-line))
- (plain (org-capture-place-plain-text))
- (item (org-capture-place-item))
- (checkitem (org-capture-place-item))))
+ (setq-local outline-level 'org-outline-level)
+ (pcase (org-capture-get :type)
+ ((or `nil `entry) (org-capture-place-entry))
+ (`table-line (org-capture-place-table-line))
+ (`plain (org-capture-place-plain-text))
+ (`item (org-capture-place-item))
+ (`checkitem (org-capture-place-item)))
(org-capture-mode 1)
- (org-set-local 'org-capture-current-plist org-capture-plist))
+ (setq-local org-capture-current-plist org-capture-plist))
(defun org-capture-place-entry ()
"Place the template as a new Org entry."
(let* ((txt (org-capture-get :template))
(reversed (org-capture-get :prepend))
(target-entry-p (org-capture-get :target-entry-p))
- level beg end file)
+ level beg end)
(and (org-capture-get :exact-position)
(goto-char (org-capture-get :exact-position)))
(cond
((not target-entry-p)
- ;; Insert as top-level entry, either at beginning or at end of file
+ ;; Insert as top-level entry, either at beginning or at end of
+ ;; file.
(setq level 1)
(if reversed
(progn (goto-char (point-min))
@@ -1136,7 +1160,7 @@ may have been stored before."
(let* ((txt (org-capture-get :template))
(target-entry-p (org-capture-get :target-entry-p))
(table-line-pos (org-capture-get :table-line-pos))
- ind beg end)
+ beg end)
(cond
((org-capture-get :exact-position)
(goto-char (org-capture-get :exact-position)))
@@ -1167,6 +1191,7 @@ may have been stored before."
(cond
((and table-line-pos
(string-match "\\(I+\\)\\([-+][0-9]\\)" table-line-pos))
+ (goto-char (point-min))
;; we have a complex line specification
(let ((ll (ignore-errors
(save-match-data (org-table-analyze))
@@ -1284,16 +1309,14 @@ Of course, if exact position has been required, just put it there."
(point-at-bol))
(point))))))
(with-current-buffer (buffer-base-buffer (current-buffer))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char pos)
- (let ((bookmark-name (plist-get org-bookmark-names-plist
- :last-capture)))
- (when bookmark-name
- (with-demoted-errors
- (bookmark-set bookmark-name))))
- (move-marker org-capture-last-stored-marker (point)))))))
+ (org-with-wide-buffer
+ (goto-char pos)
+ (let ((bookmark-name (plist-get org-bookmark-names-plist
+ :last-capture)))
+ (when bookmark-name
+ (with-demoted-errors
+ (bookmark-set bookmark-name))))
+ (move-marker org-capture-last-stored-marker (point))))))
(defun org-capture-narrow (beg end)
"Narrow, unless configuration says not to narrow."
@@ -1379,13 +1402,11 @@ Point will remain at the first line after the inserted text."
"Go to the target location of a capture template.
The user is queried for the template."
(interactive)
- (let* (org-select-template-temp-major-mode
- (entry (org-capture-select-template template-key)))
- (unless entry
- (error "No capture template selected"))
+ (let ((entry (org-capture-select-template template-key)))
+ (unless entry (error "No capture template selected"))
(org-capture-set-plist entry)
(org-capture-set-target-location)
- (org-pop-to-buffer-same-window (org-capture-get :buffer))
+ (pop-to-buffer-same-window (org-capture-get :buffer))
(goto-char (org-capture-get :pos))))
(defun org-capture-get-indirect-buffer (&optional buffer prefix)
@@ -1395,7 +1416,7 @@ Use PREFIX as a prefix for the name of the indirect buffer."
(let ((n 1) (base (buffer-name buffer)) bname)
(setq bname (concat prefix "-" base))
(while (buffer-live-p (get-buffer bname))
- (setq bname (concat prefix "-" (number-to-string (incf n)) "-" base)))
+ (setq bname (concat prefix "-" (number-to-string (cl-incf n)) "-" base)))
(condition-case nil
(make-indirect-buffer buffer bname 'clone)
(error
@@ -1450,7 +1471,7 @@ only the bare key is returned."
(cond
((and (= 2 (length (car tbl))) (= (length (caar tbl)) 1))
;; This is a description on this level
- (setq dkey (caar tbl) ddesc (cadar tbl))
+ (setq dkey (caar tbl) ddesc (cl-cadar tbl))
(pop tbl)
(push dkey des-keys)
(push dkey allowed-keys)
@@ -1487,7 +1508,7 @@ only the bare key is returned."
(setq pressed (char-to-string (read-char-exclusive))))
(when (equal pressed "\C-g")
(kill-buffer buffer)
- (error "Abort"))
+ (user-error "Abort"))
(when (and (not (assoc pressed table))
(not (member pressed des-keys))
(assoc pressed specials))
@@ -1528,43 +1549,35 @@ Lisp programs can force the template by setting KEYS to a string."
(defun org-capture-fill-template (&optional template initial annotation)
"Fill a template and return the filled template as a string.
The template may still contain \"%?\" for cursor positioning."
- (setq template (or template (org-capture-get :template)))
- (when (stringp initial)
- (setq initial (org-no-properties initial)))
- (let* ((buffer (org-capture-get :buffer))
+ (let* ((template (or template (org-capture-get :template)))
+ (buffer (org-capture-get :buffer))
(file (buffer-file-name (or (buffer-base-buffer buffer) buffer)))
- (ct (org-capture-get :default-time))
- (dct (decode-time ct))
- (ct1
- (if (< (nth 2 dct) org-extend-today-until)
- (encode-time 0 59 23 (1- (nth 3 dct)) (nth 4 dct) (nth 5 dct))
- ct))
- (plist-p (if org-store-link-plist t nil))
- (v-c (and (> (length kill-ring) 0) (current-kill 0)))
+ (time (let* ((c (or (org-capture-get :default-time) (current-time)))
+ (d (decode-time c)))
+ (if (< (nth 2 d) org-extend-today-until)
+ (encode-time 0 59 23 (1- (nth 3 d)) (nth 4 d) (nth 5 d))
+ c)))
+ (v-t (format-time-string (org-time-stamp-format nil) time))
+ (v-T (format-time-string (org-time-stamp-format t) time))
+ (v-u (format-time-string (org-time-stamp-format nil t) time))
+ (v-U (format-time-string (org-time-stamp-format t t) time))
+ (v-c (and kill-ring (current-kill 0)))
(v-x (or (org-get-x-clipboard 'PRIMARY)
(org-get-x-clipboard 'CLIPBOARD)
(org-get-x-clipboard 'SECONDARY)))
- (v-t (format-time-string (car org-time-stamp-formats) ct1))
- (v-T (format-time-string (cdr org-time-stamp-formats) ct1))
- (v-u (concat "[" (substring v-t 1 -1) "]"))
- (v-U (concat "[" (substring v-T 1 -1) "]"))
- ;; `initial' and `annotation' might habe been passed.
- ;; But if the property list has them, we prefer those values
+ ;; `initial' and `annotation' might have been passed. But if
+ ;; the property list has them, we prefer those values.
(v-i (or (plist-get org-store-link-plist :initial)
- initial
+ (and (stringp initial) (org-no-properties initial))
(org-capture-get :initial)
""))
- (v-a (or (plist-get org-store-link-plist :annotation)
- annotation
- (org-capture-get :annotation)
- ""))
- ;; Is the link empty? Then we do not want it...
- (v-a (if (equal v-a "[[]]") "" v-a))
- (clipboards (remove nil (list v-i
- (org-get-x-clipboard 'PRIMARY)
- (org-get-x-clipboard 'CLIPBOARD)
- (org-get-x-clipboard 'SECONDARY)
- v-c)))
+ (v-a
+ (let ((a (or (plist-get org-store-link-plist :annotation)
+ annotation
+ (org-capture-get :annotation)
+ "")))
+ ;; Is the link empty? Then we do not want it...
+ (if (equal a "[[]]") "" a)))
(l-re "\\[\\[\\(.*?\\)\\]\\(\\[.*?\\]\\)?\\]")
(v-A (if (and v-a (string-match l-re v-a))
(replace-match "[[\\1][%^{Link description}]]" nil nil v-a)
@@ -1573,203 +1586,256 @@ The template may still contain \"%?\" for cursor positioning."
(replace-match "\\1" nil nil v-a)
v-a))
(v-n user-full-name)
- (v-k (if (marker-buffer org-clock-marker)
- (org-no-properties org-clock-heading)))
+ (v-k (and (marker-buffer org-clock-marker)
+ (org-no-properties org-clock-heading)))
(v-K (if (marker-buffer org-clock-marker)
(org-make-link-string
(buffer-file-name (marker-buffer org-clock-marker))
org-clock-heading)))
(v-f (or (org-capture-get :original-file-nondirectory) ""))
(v-F (or (org-capture-get :original-file) ""))
- v-I
- (org-startup-folded nil)
- (org-inhibit-startup t)
- org-time-was-given org-end-time-was-given x
- prompt completions char time pos default histvar strings)
-
- (setq org-store-link-plist
- (plist-put org-store-link-plist :annotation v-a)
- org-store-link-plist
- (plist-put org-store-link-plist :initial v-i))
- (setq initial v-i)
-
- (unless template (setq template "") (message "No template") (ding)
- (sit-for 1))
+ (clipboards (delq nil
+ (list v-i
+ (org-get-x-clipboard 'PRIMARY)
+ (org-get-x-clipboard 'CLIPBOARD)
+ (org-get-x-clipboard 'SECONDARY)
+ v-c))))
+
+ (setq org-store-link-plist (plist-put org-store-link-plist :annotation v-a))
+ (setq org-store-link-plist (plist-put org-store-link-plist :initial v-i))
+
+ (unless template
+ (setq template "")
+ (message "no template") (ding)
+ (sit-for 1))
(save-window-excursion
(org-switch-to-buffer-other-window (get-buffer-create "*Capture*"))
(erase-buffer)
+ (setq buffer-file-name nil)
+ (setq mark-active nil)
(insert template)
(goto-char (point-min))
- (org-capture-steal-local-variables buffer)
- (setq buffer-file-name nil mark-active nil)
- ;; %[] Insert contents of a file.
- (goto-char (point-min))
- (while (re-search-forward "%\\[\\(.+\\)\\]" nil t)
- (unless (org-capture-escaped-%)
- (let ((start (match-beginning 0))
- (end (match-end 0))
- (filename (expand-file-name (match-string 1))))
- (goto-char start)
- (delete-region start end)
- (condition-case error
- (insert-file-contents filename)
- (error (insert (format "%%![Couldn not insert %s: %s]"
- filename error)))))))
-
- ;; The current time
- (goto-char (point-min))
- (while (re-search-forward "%<\\([^>\n]+\\)>" nil t)
- (replace-match (format-time-string (match-string 1)) t t))
+ ;; %[] insert contents of a file.
+ (save-excursion
+ (while (re-search-forward "%\\[\\(.+\\)\\]" nil t)
+ (let ((filename (expand-file-name (match-string 1)))
+ (beg (copy-marker (match-beginning 0)))
+ (end (copy-marker (match-end 0))))
+ (unless (org-capture-escaped-%)
+ (delete-region beg end)
+ (set-marker beg nil)
+ (set-marker end nil)
+ (condition-case error
+ (insert-file-contents filename)
+ (error
+ (insert (format "%%![couldn not insert %s: %s]"
+ filename
+ error))))))))
- ;; Simple %-escapes
- (goto-char (point-min))
- (while (re-search-forward "%\\([tTuUaliAcxkKInfF]\\)" nil t)
- (unless (org-capture-escaped-%)
- (when (and initial (equal (match-string 0) "%i"))
- (save-match-data
- (let* ((lead (buffer-substring
- (point-at-bol) (match-beginning 0))))
- (setq v-i (mapconcat 'identity
- (org-split-string initial "\n")
- (concat "\n" lead))))))
- (replace-match (or (eval (intern (concat "v-" (match-string 1)))) "")
- t t)))
-
- ;; From the property list
- (when plist-p
- (goto-char (point-min))
- (while (re-search-forward "%\\(:[-a-zA-Z]+\\)" nil t)
- (unless (org-capture-escaped-%)
- (and (setq x (or (plist-get org-store-link-plist
- (intern (match-string 1))) ""))
- (replace-match x t t)))))
+ ;; Mark %() embedded elisp for later evaluation.
+ (org-capture-expand-embedded-elisp 'mark)
- ;; %() embedded elisp
- (goto-char (point-min))
+ ;; Expand non-interactive templates.
+ (let ((regexp "%\\(:[-a-za-z]+\\|<\\([^>\n]+\\)>\\|[aAcfFikKlntTuUx]\\)"))
+ (save-excursion
+ (while (re-search-forward regexp nil t)
+ ;; `org-capture-escaped-%' may modify buffer and cripple
+ ;; match-data. Use markers instead. Ditto for other
+ ;; templates.
+ (let ((pos (copy-marker (match-beginning 0)))
+ (end (copy-marker (match-end 0)))
+ (value (match-string 1))
+ (time-string (match-string 2)))
+ (unless (org-capture-escaped-%)
+ (delete-region pos end)
+ (set-marker pos nil)
+ (set-marker end nil)
+ (let ((replacement
+ (pcase (string-to-char value)
+ (?< (format-time-string time-string))
+ (?:
+ (or (plist-get org-store-link-plist (intern value))
+ ""))
+ (?i (let ((lead (buffer-substring-no-properties
+ (line-beginning-position) (point))))
+ (mapconcat #'identity
+ (split-string v-i "\n")
+ (concat "\n" lead))))
+ (?a v-a)
+ (?A v-A)
+ (?c v-c)
+ (?f v-f)
+ (?F v-F)
+ (?k v-k)
+ (?K v-K)
+ (?l v-l)
+ (?n v-n)
+ (?t v-t)
+ (?T v-T)
+ (?u v-u)
+ (?U v-U)
+ (?x v-x))))
+ (insert
+ (if (org-capture-inside-embedded-elisp-p)
+ (replace-regexp-in-string "\"" "\\\\\"" replacement)
+ replacement))))))))
+
+ ;; Expand %() embedded Elisp. Limit to Sexp originally marked.
(org-capture-expand-embedded-elisp)
- ;; Turn on org-mode in temp buffer, set local variables
- ;; This is to support completion in interactive prompts
+ ;; Expand interactive templates. This is the last step so that
+ ;; template is mostly expanded when prompting happens. Turn on
+ ;; Org mode and set local variables. This is to support
+ ;; completion in interactive prompts.
(let ((org-inhibit-startup t)) (org-mode))
- ;; Interactive template entries
- (goto-char (point-min))
- (while (re-search-forward "%^\\({\\([^}]*\\)}\\)?\\([gGtTuUCLp]\\)?" nil t)
- (unless (org-capture-escaped-%)
- (setq char (if (match-end 3) (match-string-no-properties 3))
- prompt (if (match-end 2) (match-string-no-properties 2)))
- (goto-char (match-beginning 0))
- (replace-match "")
- (setq completions nil default nil)
- (when prompt
- (setq completions (org-split-string prompt "|")
- prompt (pop completions)
- default (car completions)
- histvar (intern (concat
- "org-capture-template-prompt-history::"
- (or prompt "")))
- completions (mapcar 'list completions)))
- (unless (boundp histvar) (set histvar nil))
- (cond
- ((member char '("G" "g"))
- (let* ((org-last-tags-completion-table
- (org-global-tags-completion-table
- (if (equal char "G")
- (org-agenda-files)
- (and file (list file)))))
- (org-add-colon-after-tag-completion t)
- (ins (org-icompleting-read
- (if prompt (concat prompt ": ") "Tags: ")
- 'org-tags-completion-function nil nil nil
- 'org-tags-history)))
- (setq ins (mapconcat 'identity
- (org-split-string
- ins (org-re "[^[:alnum:]_@#%]+"))
- ":"))
- (when (string-match "\\S-" ins)
- (or (equal (char-before) ?:) (insert ":"))
- (insert ins)
- (or (equal (char-after) ?:) (insert ":"))
- (and (org-at-heading-p)
- (let ((org-ignore-region t))
- (org-set-tags nil 'align))))))
- ((equal char "C")
- (cond ((= (length clipboards) 1) (insert (car clipboards)))
- ((> (length clipboards) 1)
- (insert (read-string "Clipboard/kill value: "
- (car clipboards) '(clipboards . 1)
- (car clipboards))))))
- ((equal char "L")
- (cond ((= (length clipboards) 1)
- (org-insert-link 0 (car clipboards)))
- ((> (length clipboards) 1)
- (org-insert-link 0 (read-string "Clipboard/kill value: "
- (car clipboards)
- '(clipboards . 1)
- (car clipboards))))))
- ((equal char "p")
- (org-set-property (org-no-properties prompt) nil))
- (char
- ;; These are the date/time related ones
- (setq org-time-was-given (equal (upcase char) char))
- (setq time (org-read-date (equal (upcase char) char) t nil
- prompt))
- (if (equal (upcase char) char) (setq org-time-was-given t))
- (org-insert-time-stamp time org-time-was-given
- (member char '("u" "U"))
- nil nil (list org-end-time-was-given)))
- (t
- (let (org-completion-use-ido)
- (push (org-completing-read-no-i
- (concat (if prompt prompt "Enter string")
- (if default (concat " [" default "]"))
- ": ")
- completions nil nil nil histvar default)
- strings)
- (insert (car strings)))))))
- ;; Replace %n escapes with nth %^{...} string
- (setq strings (nreverse strings))
- (goto-char (point-min))
- (while (re-search-forward "%\\\\\\([1-9][0-9]*\\)" nil t)
- (unless (org-capture-escaped-%)
- (replace-match
- (nth (1- (string-to-number (match-string 1))) strings)
- nil t)))
+ (org-clone-local-variables buffer "\\`org-")
+ (let (strings) ; Stores interactive answers.
+ (save-excursion
+ (let ((regexp "%\\^\\(?:{\\([^}]*\\)}\\)?\\([CgGLptTuU]\\)?"))
+ (while (re-search-forward regexp nil t)
+ (let* ((items (and (match-end 1)
+ (save-match-data
+ (split-string (match-string-no-properties 1)
+ "|"))))
+ (key (match-string 2))
+ (beg (copy-marker (match-beginning 0)))
+ (end (copy-marker (match-end 0)))
+ (prompt (nth 0 items))
+ (default (nth 1 items))
+ (completions (nthcdr 2 items)))
+ (unless (org-capture-escaped-%)
+ (delete-region beg end)
+ (set-marker beg nil)
+ (set-marker end nil)
+ (pcase key
+ ((or "G" "g")
+ (let* ((org-last-tags-completion-table
+ (org-global-tags-completion-table
+ (cond ((equal key "G") (org-agenda-files))
+ (file (list file))
+ (t nil))))
+ (org-add-colon-after-tag-completion t)
+ (ins (mapconcat
+ #'identity
+ (org-split-string
+ (completing-read
+ (if prompt (concat prompt ": ") "Tags: ")
+ 'org-tags-completion-function nil nil nil
+ 'org-tags-history)
+ "[^[:alnum:]_@#%]+")
+ ":")))
+ (when (org-string-nw-p ins)
+ (unless (eq (char-before) ?:) (insert ":"))
+ (insert ins)
+ (unless (eq (char-after) ?:) (insert ":"))
+ (and (org-at-heading-p)
+ (let ((org-ignore-region t))
+ (org-set-tags nil 'align))))))
+ ("C"
+ (cond
+ ((= (length clipboards) 1) (insert (car clipboards)))
+ ((> (length clipboards) 1)
+ (insert (read-string "Clipboard/kill value: "
+ (car clipboards)
+ '(clipboards . 1)
+ (car clipboards))))))
+ ("L"
+ (cond ((= (length clipboards) 1)
+ (org-insert-link 0 (car clipboards)))
+ ((> (length clipboards) 1)
+ (org-insert-link
+ 0
+ (read-string "Clipboard/kill value: "
+ (car clipboards)
+ '(clipboards . 1)
+ (car clipboards))))))
+ ("p" (org-set-property prompt nil))
+ ((guard key)
+ ;; These are the date/time related ones.
+ (let* ((upcase? (equal (upcase key) key))
+ (org-time-was-given upcase?)
+ (org-end-time-was-given)
+ (time (org-read-date upcase? t nil prompt)))
+ (org-insert-time-stamp
+ time org-time-was-given
+ (member key '("u" "U"))
+ nil nil (list org-end-time-was-given))))
+ (_
+ (push (org-completing-read
+ (concat (or prompt "Enter string")
+ (and default (format " [%s]" default))
+ ": ")
+ completions nil nil nil nil default)
+ strings)
+ (insert (car strings)))))))))
+
+ ;; Replace %n escapes with nth %^{...} string.
+ (setq strings (nreverse strings))
+ (save-excursion
+ (while (re-search-forward "%\\\\\\([1-9][0-9]*\\)" nil t)
+ (unless (org-capture-escaped-%)
+ (replace-match
+ (nth (1- (string-to-number (match-string 1))) strings)
+ nil t)))))
+
;; Make sure there are no empty lines before the text, and that
- ;; it ends with a newline character
- (goto-char (point-min))
- (while (looking-at "[ \t]*\n") (replace-match ""))
- (if (re-search-forward "[ \t\n]*\\'" nil t) (replace-match "\n"))
- ;; Return the expanded template and kill the temporary buffer
+ ;; it ends with a newline character.
+ (skip-chars-forward " \t\n")
+ (delete-region (point-min) (line-beginning-position))
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) (point-max))
+ (insert "\n")
+
+ ;; Return the expanded template and kill the capture buffer.
(untabify (point-min) (point-max))
(set-buffer-modified-p nil)
- (prog1 (buffer-string) (kill-buffer (current-buffer))))))
+ (prog1 (buffer-substring-no-properties (point-min) (point-max))
+ (kill-buffer (current-buffer))))))
(defun org-capture-escaped-% ()
- "Check if % was escaped - if yes, unescape it now."
- (if (equal (char-before (match-beginning 0)) ?\\)
- (progn
- (delete-region (1- (match-beginning 0)) (match-beginning 0))
- t)
- nil))
-
-(defun org-capture-expand-embedded-elisp ()
- "Evaluate embedded elisp %(sexp) and replace with the result."
- (goto-char (point-min))
- (while (re-search-forward "%(" nil t)
- (unless (org-capture-escaped-%)
- (goto-char (match-beginning 0))
- (let ((template-start (point)))
- (forward-char 1)
- (let* ((sexp (read (current-buffer)))
- (result (org-eval
- (org-capture--expand-keyword-in-embedded-elisp sexp))))
- (delete-region template-start (point))
- (when result
- (if (stringp result)
- (insert result)
- (error "Capture template sexp `%s' must evaluate to string or nil"
- sexp))))))))
+ "Non-nil if % was escaped.
+If yes, unescape it now. Assume match-data contains the
+placeholder to check."
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (let ((n (abs (skip-chars-backward "\\\\"))))
+ (delete-char (/ (1+ n) 2))
+ (= (% n 2) 1))))
+
+(defun org-capture-expand-embedded-elisp (&optional mark)
+ "Evaluate embedded elisp %(sexp) and replace with the result.
+When optional MARK argument is non-nil, mark Sexp with a text
+property (`org-embedded-elisp') for later evaluation. Only
+marked Sexp are evaluated when this argument is nil."
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "%(" nil t)
+ (cond
+ ((get-text-property (match-beginning 0) 'org-embedded-elisp)
+ (goto-char (match-beginning 0))
+ (let ((template-start (point)))
+ (forward-char 1)
+ (let* ((sexp (read (current-buffer)))
+ (result (org-eval
+ (org-capture--expand-keyword-in-embedded-elisp
+ sexp))))
+ (delete-region template-start (point))
+ (cond
+ ((not result) nil)
+ ((stringp result) (insert result))
+ (t (error
+ "Capture template sexp `%s' must evaluate to string or nil"
+ sexp))))))
+ ((not mark) nil)
+ ;; Only mark valid and non-escaped sexp.
+ ((org-capture-escaped-%) nil)
+ (t
+ (let ((end (with-syntax-table emacs-lisp-mode-syntax-table
+ (ignore-errors (scan-sexps (1- (point)) 1)))))
+ (when end
+ (put-text-property (- (point) 2) end 'org-embedded-elisp t))))))))
(defun org-capture--expand-keyword-in-embedded-elisp (attr)
"Recursively replace capture link keywords in ATTR sexp.
@@ -1786,20 +1852,10 @@ Such keywords are prefixed with \"%:\". See
(t attr)))
(defun org-capture-inside-embedded-elisp-p ()
- "Return non-nil if point is inside of embedded elisp %(sexp)."
- (let (beg end)
- (with-syntax-table emacs-lisp-mode-syntax-table
- (save-excursion
- ;; `looking-at' and `search-backward' below do not match the "%(" if
- ;; point is in its middle
- (when (equal (char-before) ?%)
- (backward-char))
- (save-match-data
- (when (or (looking-at "%(") (search-backward "%(" nil t))
- (setq beg (point))
- (setq end (progn (forward-char) (forward-sexp) (1- (point)))))))
- (when (and beg end)
- (and (<= (point) end) (>= (point) beg))))))
+ "Non-nil if point is inside of embedded elisp %(sexp).
+Assume sexps have been marked with
+`org-capture-expand-embedded-elisp' beforehand."
+ (get-text-property (point) 'org-embedded-elisp))
;;;###autoload
(defun org-capture-import-remember-templates ()
@@ -1843,6 +1899,9 @@ Such keywords are prefixed with \"%:\". See
(if jump-to-captured '(:jump-to-captured t)))))
org-remember-templates))))
+;;; The function was made obsolete by commit 65399674d5 of
+;;; 2013-02-22. This make-obsolete call was added 2016-09-01.
+(make-obsolete 'org-capture-import-remember-templates "use the `org-capture-templates' variable instead." "Org 9.0")
(provide 'org-capture)
diff --git a/lisp/org-clock.el b/lisp/org-clock.el
index 143f749..b148a08 100644
--- a/lisp/org-clock.el
+++ b/lisp/org-clock.el
@@ -1,4 +1,4 @@
-;;; org-clock.el --- The time clocking code for Org-mode
+;;; org-clock.el --- The time clocking code for Org mode -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2016 Free Software Foundation, Inc.
@@ -24,26 +24,28 @@
;;
;;; Commentary:
-;; This file contains the time clocking code for Org-mode
+;; This file contains the time clocking code for Org mode
;;; Code:
-(eval-when-compile
- (require 'cl))
+(require 'cl-lib)
(require 'org)
-(declare-function calendar-iso-to-absolute "cal-iso" (&optional date))
+(declare-function calendar-iso-to-absolute "cal-iso" (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-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-clock-stored-history nil
+ "Clock history, populated by `org-clock-load', which see.")
+(defvar org-frame-title-format-backup frame-title-format)
(defvar org-time-stamp-formats)
(defvar org-ts-what)
-(defvar org-frame-title-format-backup frame-title-format)
+
(defgroup org-clock nil
- "Options concerning clocking working time in Org-mode."
+ "Options concerning clocking working time in Org mode."
:tag "Org Clock"
:group 'org-progress)
@@ -65,7 +67,7 @@ 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"
+ :version "25.2"
:package-version '(Org . "8.3")
:type '(choice
(const :tag "Always" t)
@@ -85,7 +87,7 @@ Return value is either a string, an integer, or nil."
(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))
+ (if (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)
@@ -235,9 +237,6 @@ file name Play this sound file, fall back to beep"
(const :tag "Standard beep" t)
(file :tag "Play sound file")))
-(define-obsolete-variable-alias 'org-clock-modeline-total
- 'org-clock-mode-line-total "24.3")
-
(defcustom org-clock-mode-line-total 'auto
"Default setting for the time included for the mode line clock.
This can be overruled locally using the CLOCK_MODELINE_TOTAL property.
@@ -256,7 +255,7 @@ auto Automatically, either `all', or `repeat' for repeating tasks"
(const :tag "All task time" all)
(const :tag "Automatically, `all' or since `repeat'" auto)))
-(org-defvaralias 'org-task-overrun-text 'org-clock-task-overrun-text)
+(defvaralias 'org-task-overrun-text 'org-clock-task-overrun-text)
(defcustom org-clock-task-overrun-text nil
"Extra mode line text to indicate that the clock is overrun.
The can be nil to indicate that instead of adding text, the clock time
@@ -280,14 +279,14 @@ string as argument."
(function :tag "Function")))
(defgroup org-clocktable nil
- "Options concerning the clock table in Org-mode."
+ "Options concerning the clock table in Org mode."
:tag "Org Clock Table"
:group 'org-clock)
(defcustom org-clocktable-defaults
(list
:maxlevel 2
- :lang (or (org-bound-and-true-p org-export-default-language) "en")
+ :lang (or (bound-and-true-p org-export-default-language) "en")
:scope 'file
:block nil
:wstart 1
@@ -383,7 +382,7 @@ play with them."
:type 'string)
(defcustom org-clock-clocked-in-display 'mode-line
- "When clocked in for a task, org-mode can display the current
+ "When clocked in for a task, Org can display the current
task and accumulated time in the mode line and/or frame title.
Allowed values are:
@@ -466,7 +465,7 @@ to add an effort property.")
(let* ((dichotomy
(lambda (min max pred)
(if (funcall pred min) min
- (incf min)
+ (cl-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)))))
@@ -554,13 +553,15 @@ of a different task.")
(org-check-and-save-marker org-clock-hd-marker beg end)
(org-check-and-save-marker org-clock-default-task beg end)
(org-check-and-save-marker org-clock-interrupted-task beg end)
- (mapc (lambda (m) (org-check-and-save-marker m beg end))
- org-clock-history))
+ (dolist (m org-clock-history)
+ (org-check-and-save-marker m beg end)))
(defun org-clock-drawer-name ()
"Return clock drawer's name for current entry, or nil."
(let ((drawer (org-clock-into-drawer)))
- (cond ((integerp drawer) (org-log-into-drawer))
+ (cond ((integerp drawer)
+ (let ((log-drawer (org-log-into-drawer)))
+ (if (stringp log-drawer) log-drawer "LOGBOOK")))
((stringp drawer) drawer)
(t nil))))
@@ -580,8 +581,8 @@ of a different task.")
(interactive)
(let (och chl sel-list rpl (i 0) s)
;; Remove successive dups from the clock history to consider
- (mapc (lambda (c) (if (not (equal c (car och))) (push c och)))
- org-clock-history)
+ (dolist (c org-clock-history)
+ (unless (equal c (car och)) (push c och)))
(setq och (reverse och) chl (length och))
(if (zerop chl)
(user-error "No recent clock")
@@ -602,17 +603,15 @@ of a different task.")
(setq s (org-clock-insert-selection-line ?c org-clock-marker))
(push s sel-list))
(insert (org-add-props "Recent Tasks\n" nil 'face 'bold))
- (mapc
- (lambda (m)
- (when (marker-buffer m)
- (setq i (1+ i)
- s (org-clock-insert-selection-line
- (if (< i 10)
- (+ i ?0)
- (+ i (- ?A 10))) m))
- (if (fboundp 'int-to-char) (setf (car s) (int-to-char (car s))))
- (push s sel-list)))
- och)
+ (dolist (m och)
+ (when (marker-buffer m)
+ (setq i (1+ i)
+ s (org-clock-insert-selection-line
+ (if (< i 10)
+ (+ i ?0)
+ (+ i (- ?A 10))) m))
+ (if (fboundp 'int-to-char) (setf (car s) (int-to-char (car s))))
+ (push s sel-list)))
(run-hooks 'org-clock-before-select-task-hook)
(goto-char (point-min))
;; Set min-height relatively to circumvent a possible but in
@@ -632,25 +631,22 @@ of a different task.")
And return a cons cell with the selection character integer and the marker
pointing to it."
(when (marker-buffer marker)
- (let (file cat task heading prefix)
+ (let (cat task heading prefix)
(with-current-buffer (org-base-buffer (marker-buffer marker))
- (save-excursion
- (save-restriction
- (widen)
- (ignore-errors
- (goto-char marker)
- (setq file (buffer-file-name (marker-buffer marker))
- cat (org-get-category)
- heading (org-get-heading 'notags)
- prefix (save-excursion
- (org-back-to-heading t)
- (looking-at org-outline-regexp)
- (match-string 0))
- task (substring
- (org-fontify-like-in-org-mode
- (concat prefix heading)
- org-odd-levels-only)
- (length prefix)))))))
+ (org-with-wide-buffer
+ (ignore-errors
+ (goto-char marker)
+ (setq cat (org-get-category)
+ heading (org-get-heading 'notags)
+ prefix (save-excursion
+ (org-back-to-heading t)
+ (looking-at org-outline-regexp)
+ (match-string 0))
+ task (substring
+ (org-fontify-like-in-org-mode
+ (concat prefix heading)
+ org-odd-levels-only)
+ (length prefix))))))
(when (and cat task)
(insert (format "[%c] %-12s %s\n" i cat task))
(cons i marker)))))
@@ -670,19 +666,19 @@ If not, show simply the clocked time like 01:50."
(let* ((effort-in-minutes
(org-duration-string-to-minutes org-clock-effort))
(work-done-str
- (org-propertize
+ (propertize
(org-minutes-to-clocksum-string clocked-time)
'face (if (and org-clock-task-overrun (not org-clock-task-overrun-text))
'org-mode-line-clock-overrun 'org-mode-line-clock)))
(effort-str (org-minutes-to-clocksum-string effort-in-minutes))
- (clockstr (org-propertize
+ (clockstr (propertize
(concat " [%s/" effort-str
"] (" (replace-regexp-in-string "%" "%%" org-clock-heading) ")")
'face 'org-mode-line-clock)))
(format clockstr work-done-str))
- (org-propertize (concat "[" (org-minutes-to-clocksum-string clocked-time)
- (format " (%s)" org-clock-heading) "]")
- 'face 'org-mode-line-clock))))
+ (propertize (concat "[" (org-minutes-to-clocksum-string clocked-time)
+ "]" (format " (%s)" org-clock-heading))
+ 'face 'org-mode-line-clock))))
(defun org-clock-get-last-clock-out-time ()
"Get the last clock-out time for the current subtree."
@@ -697,20 +693,21 @@ If not, show simply the clocked time like 01:50."
(org-clock-notify-once-if-expired)
(setq org-clock-task-overrun nil))
(setq org-mode-line-string
- (org-propertize
+ (propertize
(let ((clock-string (org-clock-get-clock-string))
- (help-text "Org-mode clock is running.\nmouse-1 shows a menu\nmouse-2 will jump to task"))
+ (help-text "Org mode clock is running.\nmouse-1 shows a \
+menu\nmouse-2 will jump to task"))
(if (and (> org-clock-string-limit 0)
(> (length clock-string) org-clock-string-limit))
- (org-propertize
+ (propertize
(substring clock-string 0 org-clock-string-limit)
'help-echo (concat help-text ": " org-clock-heading))
- (org-propertize clock-string 'help-echo help-text)))
+ (propertize clock-string 'help-echo help-text)))
'local-map org-clock-mode-line-map
- 'mouse-face (if (featurep 'xemacs) 'highlight 'mode-line-highlight)))
+ 'mouse-face 'mode-line-highlight))
(if (and org-clock-task-overrun org-clock-task-overrun-text)
(setq org-mode-line-string
- (concat (org-propertize
+ (concat (propertize
org-clock-task-overrun-text
'face 'org-mode-line-clock-overrun) org-mode-line-string)))
(force-mode-line-update))
@@ -720,8 +717,8 @@ If not, show simply the clocked time like 01:50."
The time returned includes the time spent on this task in
previous clocking intervals."
(let ((currently-clocked-time
- (floor (- (org-float-time)
- (org-float-time org-clock-start-time)) 60)))
+ (floor (- (float-time)
+ (float-time org-clock-start-time)) 60)))
(+ currently-clocked-time (or org-clock-total-time 0))))
(defun org-clock-modify-effort-estimate (&optional value)
@@ -801,7 +798,7 @@ use libnotify if available, or fall back on a message."
org-show-notification-handler notification))
((fboundp 'notifications-notify)
(notifications-notify
- :title "Org-mode message"
+ :title "Org mode message"
:body notification
;; FIXME how to link to the Org icon?
;; :app-icon "~/.emacs.d/icons/mail.png"
@@ -856,12 +853,10 @@ If CLOCK-SOUND is non-nil, it overrides `org-clock-sound'."
(defmacro org-with-clock-position (clock &rest forms)
"Evaluate FORMS with CLOCK as the current active clock."
`(with-current-buffer (marker-buffer (car ,clock))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (car ,clock))
- (beginning-of-line)
- ,@forms))))
+ (org-with-wide-buffer
+ (goto-char (car ,clock))
+ (beginning-of-line)
+ ,@forms)))
(def-edebug-spec org-with-clock-position (form body))
(put 'org-with-clock-position 'lisp-indent-function 1)
@@ -970,7 +965,7 @@ If necessary, clock-out of the currently active clock."
(throw 'exit nil)))))))))))
(defun org-clock-resolve (clock &optional prompt-fn last-valid fail-quietly)
- "Resolve an open org-mode clock.
+ "Resolve an open Org clock.
An open clock was found, with `dangling' possibly being non-nil.
If this function was invoked with a prefix argument, non-dangling
open clocks are ignored. The given clock requires some sort of
@@ -988,7 +983,7 @@ The format of clock is (CONS MARKER START-TIME), where MARKER
identifies the buffer and position the clock is open at (and
thus, the heading it's under), and START-TIME is when the clock
was started."
- (assert clock)
+ (cl-assert clock)
(let* ((ch
(save-window-excursion
(save-excursion
@@ -1021,10 +1016,6 @@ For all these options, using uppercase makes your final state
to be CLOCKED OUT."))))
(org-fit-window-to-buffer (get-buffer-window "*Org Clock*"))
(let (char-pressed)
- (when (featurep 'xemacs)
- (message (concat (funcall prompt-fn clock)
- " [jkKgGsScCiq]? "))
- (setq char-pressed (read-char-exclusive)))
(while (or (null char-pressed)
(and (not (memq char-pressed
'(?k ?K ?g ?G ?s ?S ?C
@@ -1036,7 +1027,7 @@ to be CLOCKED OUT."))))
nil 45)))
(and (not (memq char-pressed '(?i ?q))) char-pressed)))))
(default
- (floor (/ (org-float-time
+ (floor (/ (float-time
(time-subtract (current-time) last-valid)) 60)))
(keep
(and (memq ch '(?k ?K))
@@ -1045,8 +1036,8 @@ to be CLOCKED OUT."))))
(and (memq ch '(?g ?G))
(read-number "Got back how many minutes ago? " default)))
(subtractp (memq ch '(?s ?S)))
- (barely-started-p (< (- (org-float-time last-valid)
- (org-float-time (cdr clock))) 45))
+ (barely-started-p (< (- (float-time last-valid)
+ (float-time (cdr clock))) 45))
(start-over (and subtractp barely-started-p)))
(cond
((memq ch '(?j ?J))
@@ -1086,7 +1077,7 @@ to be CLOCKED OUT."))))
;;;###autoload
(defun org-resolve-clocks (&optional only-dangling-p prompt-fn last-valid)
- "Resolve all currently open org-mode clocks.
+ "Resolve all currently open Org clocks.
If `only-dangling-p' is non-nil, only ask to resolve dangling
\(i.e., not currently open and valid) clocks."
(interactive "P")
@@ -1105,8 +1096,8 @@ 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)
- (org-float-time (cdr clock)))
+ (floor (- (float-time)
+ (float-time (cdr clock)))
60)))))
(or last-valid
(cdr clock)))))))))))
@@ -1115,7 +1106,7 @@ If `only-dangling-p' is non-nil, only ask to resolve dangling
"Return the current Emacs idle time in seconds, or nil if not idle."
(let ((idle-time (current-idle-time)))
(if idle-time
- (org-float-time idle-time)
+ (float-time idle-time)
0)))
(defun org-mac-idle-seconds ()
@@ -1149,7 +1140,7 @@ This routine returns a floating point number."
(defvar org-clock-user-idle-seconds)
(defun org-resolve-clocks-if-idle ()
- "Resolve all currently open org-mode clocks.
+ "Resolve all currently open Org clocks.
This is performed after `org-clock-idle-time' minutes, to check
if the user really wants to stay clocked in after being idle for
so long."
@@ -1164,13 +1155,12 @@ so long."
(org-clock-resolve
(cons org-clock-marker
org-clock-start-time)
- (function
- (lambda (clock)
- (format "Clocked in & idle for %.1f mins"
- (/ (org-float-time
- (time-subtract (current-time)
- org-clock-user-idle-start))
- 60.0))))
+ (lambda (_)
+ (format "Clocked in & idle for %.1f mins"
+ (/ (float-time
+ (time-subtract (current-time)
+ org-clock-user-idle-start))
+ 60.0)))
org-clock-user-idle-start)))))
(defvar org-clock-current-task nil "Task currently clocked in.")
@@ -1180,15 +1170,22 @@ so long."
;;;###autoload
(defun org-clock-in (&optional select start-time)
"Start the clock on the current item.
+
If necessary, clock-out of the currently active clock.
-With a prefix argument SELECT (\\[universal-argument]), offer a list of recently clocked
-tasks to clock into. When SELECT is \\[universal-argument] \\[universal-argument], clock into the current task
-and mark it as the default task, a special task that will always be offered
-in the clocking selection, associated with the letter `d'.
-When SELECT is \\[universal-argument] \\[universal-argument] \\[universal-argument], \
-clock in by using the last clock-out
-time as the start time \(see `org-clock-continuously' to
-make this the default behavior.)"
+
+With a `\\[universal-argument]' prefix argument SELECT, offer a list of \
+recently clocked
+tasks to clock into.
+
+When SELECT is `\\[universal-argument] \ \\[universal-argument]', \
+clock into the current task and mark it as
+the default task, a special task that will always be offered in the
+clocking selection, associated with the letter `d'.
+
+When SELECT is `\\[universal-argument] \\[universal-argument] \
+\\[universal-argument]', clock in by using the last clock-out
+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
@@ -1208,7 +1205,7 @@ make this the default behavior.)"
(not org-clock-resolving-clocks))
(setq org-clock-leftover-time nil)
(let ((org-clock-clocking-in t))
- (org-resolve-clocks))) ; check if any clocks are dangling
+ (org-resolve-clocks))) ; check if any clocks are dangling
(when (equal select '(64))
;; Set start-time to `org-clock-out-time'
@@ -1261,116 +1258,116 @@ make this the default behavior.)"
(set-buffer (org-base-buffer (marker-buffer selected-task)))
(setq target-pos (marker-position selected-task))
(move-marker selected-task nil))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char target-pos)
- (org-back-to-heading t)
- (or interrupting (move-marker org-clock-interrupted-task nil))
- (run-hooks 'org-clock-in-prepare-hook)
- (org-clock-history-push)
- (setq org-clock-current-task (nth 4 (org-heading-components)))
- (cond ((functionp org-clock-in-switch-to-state)
- (looking-at org-complex-heading-regexp)
- (let ((newstate (funcall org-clock-in-switch-to-state
- (match-string 2))))
- (if newstate (org-todo newstate))))
- ((and org-clock-in-switch-to-state
- (not (looking-at (concat org-outline-regexp "[ \t]*"
- org-clock-in-switch-to-state
- "\\>"))))
- (org-todo org-clock-in-switch-to-state)))
- (setq org-clock-heading
- (cond ((and org-clock-heading-function
- (functionp org-clock-heading-function))
- (funcall org-clock-heading-function))
- ((nth 4 (org-heading-components))
- (replace-regexp-in-string
- "\\[\\[.*?\\]\\[\\(.*?\\)\\]\\]" "\\1"
- (match-string-no-properties 4)))
- (t "???")))
- (org-clock-find-position org-clock-in-resume)
- (cond
- ((and org-clock-in-resume
- (looking-at
- (concat "^[ \t]*" org-clock-string
- " \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}"
- " *\\sw+.? +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$")))
- (message "Matched %s" (match-string 1))
- (setq ts (concat "[" (match-string 1) "]"))
- (goto-char (match-end 1))
- (setq org-clock-start-time
- (apply 'encode-time
- (org-parse-time-string (match-string 1))))
- (setq org-clock-effort (org-entry-get (point) org-effort-property))
- (setq org-clock-total-time (org-clock-sum-current-item
- (org-clock-get-sum-start))))
- ((eq org-clock-in-resume 'auto-restart)
- ;; called from org-clock-load during startup,
- ;; do not interrupt, but warn!
- (message "Cannot restart clock because task does not contain unfinished clock")
- (ding)
- (sit-for 2)
- (throw 'abort nil))
- (t
- (insert-before-markers "\n")
- (backward-char 1)
- (org-indent-line)
- (when (and (save-excursion
- (end-of-line 0)
- (org-in-item-p)))
- (beginning-of-line 1)
- (org-indent-line-to (- (org-get-indentation) 2)))
- (insert org-clock-string " ")
- (setq org-clock-effort (org-entry-get (point) org-effort-property))
- (setq org-clock-total-time (org-clock-sum-current-item
- (org-clock-get-sum-start)))
- (setq org-clock-start-time
- (or (and org-clock-continuously org-clock-out-time)
- (and leftover
- (y-or-n-p
- (format
- "You stopped another clock %d mins ago; start this one from then? "
- (/ (- (org-float-time
- (org-current-time org-clock-rounding-minutes t))
- (org-float-time leftover)) 60)))
- leftover)
- start-time
- (org-current-time org-clock-rounding-minutes t)))
- (setq ts (org-insert-time-stamp org-clock-start-time
- 'with-hm 'inactive))))
- (move-marker org-clock-marker (point) (buffer-base-buffer))
- (move-marker org-clock-hd-marker
- (save-excursion (org-back-to-heading t) (point))
- (buffer-base-buffer))
- (setq org-clock-has-been-used t)
- ;; add to mode line
- (when (or (eq org-clock-clocked-in-display 'mode-line)
- (eq org-clock-clocked-in-display 'both))
- (or global-mode-string (setq global-mode-string '("")))
- (or (memq 'org-mode-line-string global-mode-string)
- (setq global-mode-string
- (append global-mode-string '(org-mode-line-string)))))
- ;; add to frame title
- (when (or (eq org-clock-clocked-in-display 'frame-title)
- (eq org-clock-clocked-in-display 'both))
- (setq frame-title-format org-clock-frame-title-format))
- (org-clock-update-mode-line)
- (when org-clock-mode-line-timer
- (cancel-timer org-clock-mode-line-timer)
- (setq org-clock-mode-line-timer nil))
- (when org-clock-clocked-in-display
- (setq org-clock-mode-line-timer
- (run-with-timer org-clock-update-period
- org-clock-update-period
- 'org-clock-update-mode-line)))
- (when org-clock-idle-timer
- (cancel-timer org-clock-idle-timer)
- (setq org-clock-idle-timer nil))
- (setq org-clock-idle-timer
- (run-with-timer 60 60 'org-resolve-clocks-if-idle))
- (message "Clock starts at %s - %s" ts org--msg-extra)
- (run-hooks 'org-clock-in-hook)))))))
+ (org-with-wide-buffer
+ (goto-char target-pos)
+ (org-back-to-heading t)
+ (or interrupting (move-marker org-clock-interrupted-task nil))
+ (run-hooks 'org-clock-in-prepare-hook)
+ (org-clock-history-push)
+ (setq org-clock-current-task (nth 4 (org-heading-components)))
+ (cond ((functionp org-clock-in-switch-to-state)
+ (let ((case-fold-search nil))
+ (looking-at org-complex-heading-regexp))
+ (let ((newstate (funcall org-clock-in-switch-to-state
+ (match-string 2))))
+ (when newstate (org-todo newstate))))
+ ((and org-clock-in-switch-to-state
+ (not (looking-at (concat org-outline-regexp "[ \t]*"
+ org-clock-in-switch-to-state
+ "\\>"))))
+ (org-todo org-clock-in-switch-to-state)))
+ (setq org-clock-heading
+ (cond ((and org-clock-heading-function
+ (functionp org-clock-heading-function))
+ (funcall org-clock-heading-function))
+ ((nth 4 (org-heading-components))
+ (replace-regexp-in-string
+ "\\[\\[.*?\\]\\[\\(.*?\\)\\]\\]" "\\1"
+ (match-string-no-properties 4)))
+ (t "???")))
+ (org-clock-find-position org-clock-in-resume)
+ (cond
+ ((and org-clock-in-resume
+ (looking-at
+ (concat "^[ \t]*" org-clock-string
+ " \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}"
+ " *\\sw+.? +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$")))
+ (message "Matched %s" (match-string 1))
+ (setq ts (concat "[" (match-string 1) "]"))
+ (goto-char (match-end 1))
+ (setq org-clock-start-time
+ (apply 'encode-time
+ (org-parse-time-string (match-string 1))))
+ (setq org-clock-effort (org-entry-get (point) org-effort-property))
+ (setq org-clock-total-time (org-clock-sum-current-item
+ (org-clock-get-sum-start))))
+ ((eq org-clock-in-resume 'auto-restart)
+ ;; called from org-clock-load during startup,
+ ;; do not interrupt, but warn!
+ (message "Cannot restart clock because task does not contain unfinished clock")
+ (ding)
+ (sit-for 2)
+ (throw 'abort nil))
+ (t
+ (insert-before-markers "\n")
+ (backward-char 1)
+ (org-indent-line)
+ (when (and (save-excursion
+ (end-of-line 0)
+ (org-in-item-p)))
+ (beginning-of-line 1)
+ (indent-line-to (- (org-get-indentation) 2)))
+ (insert org-clock-string " ")
+ (setq org-clock-effort (org-entry-get (point) org-effort-property))
+ (setq org-clock-total-time (org-clock-sum-current-item
+ (org-clock-get-sum-start)))
+ (setq org-clock-start-time
+ (or (and org-clock-continuously org-clock-out-time)
+ (and leftover
+ (y-or-n-p
+ (format
+ "You stopped another clock %d mins ago; start this one from then? "
+ (/ (- (float-time
+ (org-current-time org-clock-rounding-minutes t))
+ (float-time leftover))
+ 60)))
+ leftover)
+ start-time
+ (org-current-time org-clock-rounding-minutes t)))
+ (setq ts (org-insert-time-stamp org-clock-start-time
+ 'with-hm 'inactive))))
+ (move-marker org-clock-marker (point) (buffer-base-buffer))
+ (move-marker org-clock-hd-marker
+ (save-excursion (org-back-to-heading t) (point))
+ (buffer-base-buffer))
+ (setq org-clock-has-been-used t)
+ ;; add to mode line
+ (when (or (eq org-clock-clocked-in-display 'mode-line)
+ (eq org-clock-clocked-in-display 'both))
+ (or global-mode-string (setq global-mode-string '("")))
+ (or (memq 'org-mode-line-string global-mode-string)
+ (setq global-mode-string
+ (append global-mode-string '(org-mode-line-string)))))
+ ;; add to frame title
+ (when (or (eq org-clock-clocked-in-display 'frame-title)
+ (eq org-clock-clocked-in-display 'both))
+ (setq frame-title-format org-clock-frame-title-format))
+ (org-clock-update-mode-line)
+ (when org-clock-mode-line-timer
+ (cancel-timer org-clock-mode-line-timer)
+ (setq org-clock-mode-line-timer nil))
+ (when org-clock-clocked-in-display
+ (setq org-clock-mode-line-timer
+ (run-with-timer org-clock-update-period
+ org-clock-update-period
+ 'org-clock-update-mode-line)))
+ (when org-clock-idle-timer
+ (cancel-timer org-clock-idle-timer)
+ (setq org-clock-idle-timer nil))
+ (setq org-clock-idle-timer
+ (run-with-timer 60 60 'org-resolve-clocks-if-idle))
+ (message "Clock starts at %s - %s" ts org--msg-extra)
+ (run-hooks 'org-clock-in-hook))))))
;;;###autoload
(defun org-clock-in-last (&optional arg)
@@ -1488,7 +1485,8 @@ line and position cursor in that line."
(throw 'exit t)))))))
(goto-char beg)
(let ((clock-re (concat "^[ \t]*" org-clock-string))
- (count 0) positions first)
+ (count 0)
+ positions)
;; Count the CLOCK lines and store their positions.
(save-excursion
(while (re-search-forward clock-re end t)
@@ -1514,9 +1512,9 @@ line and position cursor in that line."
;; When a clock drawer needs to be created because of the
;; number of clock items or simply if it is missing, collect
;; all clocks in the section and wrap them within the drawer.
- ((or drawer
- (and (wholenump org-clock-into-drawer)
- (>= (1+ count) org-clock-into-drawer)))
+ ((if (wholenump org-clock-into-drawer)
+ (>= (1+ count) org-clock-into-drawer)
+ drawer)
;; Skip planning line and property drawer, if any.
(org-end-of-meta-data)
(let ((beg (point)))
@@ -1570,7 +1568,7 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
ts te s h m remove)
(setq org-clock-out-time now)
(save-excursion ; Do not replace this with `with-current-buffer'.
- (org-no-warnings (set-buffer (org-clocking-buffer)))
+ (with-no-warnings (set-buffer (org-clocking-buffer)))
(save-restriction
(widen)
(goto-char org-clock-marker)
@@ -1583,8 +1581,10 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
(delete-region (point) (point-at-eol))
(insert "--")
(setq te (org-insert-time-stamp (or at-time now) 'with-hm 'inactive))
- (setq s (- (org-float-time (apply 'encode-time (org-parse-time-string te)))
- (org-float-time (apply 'encode-time (org-parse-time-string ts))))
+ (setq s (- (float-time
+ (apply #'encode-time (org-parse-time-string te)))
+ (float-time
+ (apply #'encode-time (org-parse-time-string ts))))
h (floor (/ s 3600))
s (- s (* 3600 h))
m (floor (/ s 60))
@@ -1599,8 +1599,9 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
(move-marker org-clock-marker nil)
(move-marker org-clock-hd-marker nil)
(when org-log-note-clock-out
- (org-add-log-setup 'clock-out nil nil nil nil
- (concat "# Task: " (org-get-heading t) "\n\n")))
+ (org-add-log-setup
+ 'clock-out nil nil nil
+ (concat "# Task: " (org-get-heading t) "\n\n")))
(when org-clock-mode-line-timer
(cancel-timer org-clock-mode-line-timer)
(setq org-clock-mode-line-timer nil))
@@ -1617,10 +1618,11 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
(org-clock-out-when-done nil))
(cond
((functionp org-clock-out-switch-to-state)
- (looking-at org-complex-heading-regexp)
+ (let ((case-fold-search nil))
+ (looking-at org-complex-heading-regexp))
(let ((newstate (funcall org-clock-out-switch-to-state
(match-string 2))))
- (if newstate (org-todo newstate))))
+ (when newstate (org-todo newstate))))
((and org-clock-out-switch-to-state
(not (looking-at (concat org-outline-regexp "[ \t]*"
org-clock-out-switch-to-state
@@ -1630,18 +1632,7 @@ 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)
- (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 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)))
- (mapc (lambda (f) (funcall f)) h))
+ (run-hooks 'org-clock-out-hook)
(unless (org-clocking-p)
(setq org-clock-current-task nil)))))))
@@ -1698,13 +1689,13 @@ Optional argument N tells to change by that many units."
(let ((ts (if updatets1 ts2 ts1))
(begts (if updatets1 begts1 begts2)))
(setq tdiff
- (subtract-time
+ (time-subtract
(org-time-string-to-time org-last-changed-timestamp)
(org-time-string-to-time ts)))
(save-excursion
(goto-char begts)
(org-timestamp-change
- (round (/ (org-float-time tdiff)
+ (round (/ (float-time tdiff)
(cond ((eq org-ts-what 'minute) 60)
((eq org-ts-what 'hour) 3600)
((eq org-ts-what 'day) (* 24 3600))
@@ -1723,10 +1714,10 @@ Optional argument N tells to change by that many units."
(force-mode-line-update)
(error "No active clock"))
(save-excursion ; Do not replace this with `with-current-buffer'.
- (org-no-warnings (set-buffer (org-clocking-buffer)))
+ (with-no-warnings (set-buffer (org-clocking-buffer)))
(goto-char org-clock-marker)
- (if (org-looking-back (concat "^[ \t]*" org-clock-string ".*")
- (line-beginning-position))
+ (if (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 (point)))
(message "Clock gone, cancel the timer anyway")
@@ -1757,7 +1748,7 @@ With prefix arg SELECT, offer recently clocked tasks for selection."
(setq recent t)
(car org-clock-history))
(t (error "No active or recent clock task")))))
- (org-pop-to-buffer-same-window (marker-buffer m))
+ (pop-to-buffer-same-window (marker-buffer m))
(if (or (< m (point-min)) (> m (point-max))) (widen))
(goto-char m)
(org-show-entry)
@@ -1769,9 +1760,8 @@ With prefix arg SELECT, offer recently clocked tasks for selection."
(message "No running clock, this is the most recently clocked task"))
(run-hooks 'org-clock-goto-hook)))
-(defvar org-clock-file-total-minutes nil
+(defvar-local org-clock-file-total-minutes nil
"Holds the file total time in minutes, after a call to `org-clock-sum'.")
-(make-variable-buffer-local 'org-clock-file-total-minutes)
(defun org-clock-sum-today (&optional headline-filter)
"Sum the times for each subtree for today."
@@ -1813,8 +1803,8 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
time)
(if (stringp tstart) (setq tstart (org-time-string-to-seconds tstart)))
(if (stringp tend) (setq tend (org-time-string-to-seconds tend)))
- (if (consp tstart) (setq tstart (org-float-time tstart)))
- (if (consp tend) (setq tend (org-float-time tend)))
+ (if (consp tstart) (setq tstart (float-time tstart)))
+ (if (consp tend) (setq tend (float-time tend)))
(remove-text-properties (point-min) (point-max)
`(,(or propname :org-clock-minutes) t
:org-clock-force-headline-inclusion t))
@@ -1826,10 +1816,10 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
;; Two time stamps
(setq ts (match-string 2)
te (match-string 3)
- ts (org-float-time
- (apply 'encode-time (org-parse-time-string ts)))
- te (org-float-time
- (apply 'encode-time (org-parse-time-string te)))
+ ts (float-time
+ (apply #'encode-time (org-parse-time-string ts)))
+ te (float-time
+ (apply #'encode-time (org-parse-time-string te)))
ts (if tstart (max ts tstart) ts)
te (if tend (min te tend) te)
dt (- te ts)
@@ -1845,10 +1835,11 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
(equal (marker-position org-clock-hd-marker) (point))
tstart
tend
- (>= (org-float-time org-clock-start-time) tstart)
- (<= (org-float-time org-clock-start-time) tend))
- (let ((time (floor (- (org-float-time)
- (org-float-time org-clock-start-time)) 60)))
+ (>= (float-time org-clock-start-time) tstart)
+ (<= (float-time org-clock-start-time) tend))
+ (let ((time (floor (- (float-time)
+ (float-time org-clock-start-time))
+ 60)))
(setq t1 (+ t1 time))))
(let* ((headline-forced
(get-text-property (point)
@@ -1863,24 +1854,22 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
(when (or (> t1 0) (> (aref ltimes level) 0))
(when (or headline-included headline-forced)
(if headline-included
- (loop for l from 0 to level do
- (aset ltimes l (+ (aref ltimes l) t1))))
+ (cl-loop for l from 0 to level do
+ (aset ltimes l (+ (aref ltimes l) t1))))
(setq time (aref ltimes level))
(goto-char (match-beginning 0))
(put-text-property (point) (point-at-eol)
(or propname :org-clock-minutes) time)
- (if headline-filter
- (save-excursion
- (save-match-data
- (while
- (> (funcall outline-level) 1)
- (outline-up-heading 1 t)
- (put-text-property
- (point) (point-at-eol)
- :org-clock-force-headline-inclusion t))))))
+ (when headline-filter
+ (save-excursion
+ (save-match-data
+ (while (org-up-heading-safe)
+ (put-text-property
+ (point) (line-end-position)
+ :org-clock-force-headline-inclusion t))))))
(setq t1 0)
- (loop for l from level to (1- lmax) do
- (aset ltimes l 0)))))))
+ (cl-loop for l from level to (1- lmax) do
+ (aset ltimes l 0)))))))
(setq org-clock-file-total-minutes (aref ltimes 0))))))
(defun org-clock-sum-current-item (&optional tstart)
@@ -1896,15 +1885,18 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
"Show subtree times in the entire buffer.
By default, show the total time for the range defined in
-`org-clock-display-default-range'. With \\[universal-argument] \
+`org-clock-display-default-range'. With `\\[universal-argument]' \
prefix, show
-the total time for today instead. With \\[universal-argument] \
-\\[universal-argument] prefix, use
-a custom range, entered at the prompt. With \\[universal-argument] \
-\\[universal-argument] \\[universal-argument]
-prefix, display the total time in the echo area.
+the total time for today instead.
+
+With `\\[universal-argument] \\[universal-argument]' prefix, \
+use a custom range, entered at prompt.
-Use \\[org-clock-remove-overlays] to remove the subtree times."
+With `\\[universal-argument] \ \\[universal-argument] \
+\\[universal-argument]' prefix, display the total time in the
+echo area.
+
+Use `\\[org-clock-remove-overlays]' to remove the subtree times."
(interactive "P")
(org-clock-remove-overlays)
(let* ((todayp (equal arg '(4)))
@@ -1936,7 +1928,7 @@ Use \\[org-clock-remove-overlays] to remove the subtree times."
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
+ (add-hook 'before-change-functions 'org-clock-remove-overlays
nil 'local))))
(message (concat (format "Total file time%s: "
(cond (todayp " for today")
@@ -1947,8 +1939,7 @@ Use \\[org-clock-remove-overlays] to remove the subtree times."
" (%d hours and %d minutes)")
h m)))
-(defvar org-clock-overlays nil)
-(make-variable-buffer-local 'org-clock-overlays)
+(defvar-local org-clock-overlays nil)
(defun org-clock-put-overlay (time)
"Put an overlays on the current line, displaying TIME.
@@ -1956,10 +1947,11 @@ This creates a new overlay and stores it in `org-clock-overlays', so that it
will be easy to remove."
(let (ov tx)
(beginning-of-line)
- (when (looking-at org-complex-heading-regexp)
- (goto-char (match-beginning 4)))
+ (let ((case-fold-search nil))
+ (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))
+ tx (concat (buffer-substring-no-properties (point) (match-end 4))
(org-add-props
(make-string
(max 0 (- (- 60 (current-column))
@@ -1970,20 +1962,17 @@ will be easy to remove."
(format " %9s " (org-minutes-to-clocksum-string time))
'(face org-clock-overlay))
""))
- (if (not (featurep 'xemacs))
- (overlay-put ov 'display tx)
- (overlay-put ov 'invisible t)
- (overlay-put ov 'end-glyph (make-glyph tx)))
+ (overlay-put ov 'display tx)
(push ov org-clock-overlays)))
;;;###autoload
-(defun org-clock-remove-overlays (&optional beg end noremove)
+(defun org-clock-remove-overlays (&optional _beg _end noremove)
"Remove the occur highlights from the buffer.
-BEG and END are ignored. If NOREMOVE is nil, remove this function
-from the `before-change-functions' in the current buffer."
+If NOREMOVE is nil, remove this function from the
+`before-change-functions' in the current buffer."
(interactive)
(unless org-inhibit-highlight-removal
- (mapc 'delete-overlay org-clock-overlays)
+ (mapc #'delete-overlay org-clock-overlays)
(setq org-clock-overlays nil)
(unless noremove
(remove-hook 'before-change-functions
@@ -2201,22 +2190,22 @@ have priority."
(when (and (memq key '(quarter thisq)) (> shift 0))
(error "Looking forward with quarters isn't implemented"))))
(when (= shift 0)
- (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))))
+ (pcase 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)
+ (pcase key
+ ((or `day `today) (setq m 0 h 0 h1 24 d (+ d shift)))
+ ((or `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)
+ ((or `month `thismonth)
(setq h 0 m 0 d (or mstart 1) month (+ month shift) month1 (1+ month)))
- ((quarter thisq)
+ ((or `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.
@@ -2224,7 +2213,7 @@ have priority."
((< (+ (- 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)))
+ (tmp (cl-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))
@@ -2239,35 +2228,35 @@ have priority."
(setq shiftedy y)
(let ((qshift (* 3 (1- (+ q shift)))))
(setq m 0 h 0 d 1 month (+ 1 qshift) month1 (+ 4 qshift))))))
- ((year thisyear)
+ ((or `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)))
+ ((or `interactive `untilnow)) ; Special cases, ignore them.
+ (_ (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
+ (let* ((start (pcase key
+ (`interactive (org-read-date nil t nil "Range start? "))
+ (`untilnow org-clock--oldest-date)
+ (_ (encode-time 0 m h d month y))))
+ (end (pcase key
+ (`interactive (org-read-date nil t nil "Range end? "))
+ (`untilnow (current-time))
+ (_ (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)
+ (pcase key
+ ((or `day `today) (format-time-string "%A, %B %d, %Y" start))
+ ((or `week `thisweek) (format-time-string "week %G-W%V" start))
+ ((or `month `thismonth) (format-time-string "%B %Y" start))
+ ((or `year `thisyear) (format-time-string "the year %Y" start))
+ ((or `quarter `thisq)
(concat (org-count-quarter shiftedq)
" quarter of " (number-to-string shiftedy)))
- (interactive "(Range interactively set)")
- (untilnow "now"))))
+ (`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)
@@ -2370,25 +2359,31 @@ the currently selected interval size."
(setq params (org-combine-plists org-clocktable-defaults params))
(catch 'exit
(let* ((scope (plist-get params :scope))
+ (files (pcase scope
+ (`agenda
+ (org-agenda-files t))
+ (`agenda-with-archives
+ (org-add-archive-files (org-agenda-files t)))
+ (`file-with-archives
+ (and buffer-file-name
+ (org-add-archive-files (list buffer-file-name))))
+ (_ (or (buffer-file-name) (current-buffer)))))
(block (plist-get params :block))
(ts (plist-get params :tstart))
(te (plist-get params :tend))
- (link (plist-get params :link))
- (maxlevel (or (plist-get params :maxlevel) 3))
(ws (plist-get params :wstart))
(ms (plist-get params :mstart))
(step (plist-get params :step))
- (timestamp (plist-get params :timestamp))
(formatter (or (plist-get params :formatter)
org-clock-clocktable-formatter
'org-clocktable-write-default))
- cc range-text ipos pos one-file-with-archives
- scope-is-list tbls level)
+ cc)
;; Check if we need to do steps
(when block
;; Get the range text for the header
(setq cc (org-clock-special-range block nil t ws ms)
- ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
+ ts (car cc)
+ te (nth 1 cc)))
(when step
;; Write many tables, in steps
(unless (or block (and ts te))
@@ -2396,65 +2391,49 @@ the currently selected interval size."
(org-clocktable-steps params)
(throw 'exit nil))
- (setq ipos (point)) ; remember the insertion position
-
- ;; Get the right scope
- (setq pos (point))
- (cond
- ((and scope (listp scope) (symbolp (car scope)))
- (setq scope (eval scope)))
- ((eq scope 'agenda)
- (setq scope (org-agenda-files t)))
- ((eq scope 'agenda-with-archives)
- (setq scope (org-agenda-files t))
- (setq scope (org-add-archive-files scope)))
- ((eq scope 'file-with-archives)
- (setq scope (and buffer-file-name
- (org-add-archive-files (list buffer-file-name)))
- one-file-with-archives t)))
- (setq scope-is-list (and scope (listp scope)))
- (if scope-is-list
- ;; we collect from several files
- (let* ((files scope)
- file)
- (org-agenda-prepare-buffers files)
- (while (setq file (pop files))
- (with-current-buffer (find-buffer-visiting file)
- (save-excursion
- (save-restriction
- (push (org-clock-get-table-data file params) tbls))))))
- ;; Just from the current file
- (save-restriction
- ;; get the right range into the restriction
- (org-agenda-prepare-buffers (list (or (buffer-file-name)
- (current-buffer))))
- (cond
- ((not scope)) ; use the restriction as it is now
- ((eq scope 'file) (widen))
- ((eq scope 'subtree) (org-narrow-to-subtree))
- ((eq scope 'tree)
- (while (org-up-heading-safe))
- (org-narrow-to-subtree))
- ((and (symbolp scope) (string-match "^tree\\([0-9]+\\)$"
- (symbol-name scope)))
- (setq level (string-to-number (match-string 1 (symbol-name scope))))
- (catch 'exit
- (while (org-up-heading-safe)
- (looking-at org-outline-regexp)
- (if (<= (org-reduced-level (funcall outline-level)) level)
- (throw 'exit nil))))
- (org-narrow-to-subtree)))
- ;; do the table, with no file name.
- (push (org-clock-get-table-data nil params) tbls)))
-
- ;; OK, at this point we tbls as a list of tables, one per file
- (setq tbls (nreverse tbls))
-
- (setq params (plist-put params :multifile scope-is-list))
- (setq params (plist-put params :one-file-with-archives
- one-file-with-archives))
-
- (funcall formatter ipos tbls params))))
+ (org-agenda-prepare-buffers (if (consp files) files (list files)))
+
+ (let ((origin (point))
+ (tables
+ (if (consp files)
+ (mapcar (lambda (file)
+ (with-current-buffer (find-buffer-visiting file)
+ (save-excursion
+ (save-restriction
+ (org-clock-get-table-data file params)))))
+ files)
+ ;; Get the right restriction for the scope.
+ (cond
+ ((not scope)) ;use the restriction as it is now
+ ((eq scope 'file) (widen))
+ ((eq scope 'subtree) (org-narrow-to-subtree))
+ ((eq scope 'tree)
+ (while (org-up-heading-safe))
+ (org-narrow-to-subtree))
+ ((and (symbolp scope)
+ (string-match "\\`tree\\([0-9]+\\)\\'"
+ (symbol-name scope)))
+ (let ((level (string-to-number
+ (match-string 1 (symbol-name scope)))))
+ (catch 'exit
+ (while (org-up-heading-safe)
+ (looking-at org-outline-regexp)
+ (when (<= (org-reduced-level (funcall outline-level))
+ level)
+ (throw 'exit nil))))
+ (org-narrow-to-subtree))))
+ (list (org-clock-get-table-data nil params))))
+ (multifile
+ ;; Even though `file-with-archives' can consist of
+ ;; multiple files, we consider this is one extended file
+ ;; instead.
+ (cond ((eq scope 'file-with-archives) nil)
+ ((consp files)))))
+
+ (funcall formatter
+ origin
+ tables
+ (org-combine-plists params `(:multifile ,multifile)))))))
(defun org-clocktable-write-default (ipos tables params)
"Write out a clock table at position IPOS in the current buffer.
@@ -2469,14 +2448,12 @@ from the dynamic block definition."
;; well-defined number of columns...
(let* ((hlchars '((1 . "*") (2 . "/")))
(lwords (assoc (or (plist-get params :lang)
- (org-bound-and-true-p org-export-default-language)
+ (bound-and-true-p org-export-default-language)
"en")
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))
(narrow (plist-get params :narrow))
(ws (or (plist-get params :wstart) 1))
@@ -2490,7 +2467,6 @@ from the dynamic block definition."
(timestamp (plist-get params :timestamp))
(properties (plist-get params :properties))
(ntcol (max 1 (or (plist-get params :tcolumns) 100)))
- (rm-file-column (plist-get params :one-file-with-archives))
(indent (plist-get params :indent))
(case-fold-search t)
range-text total-time tbl level hlc formula pcol
@@ -2695,10 +2671,6 @@ from the dynamic block definition."
(org-table-goto-column pcol nil 'force)
(insert "%")))
(org-table-recalculate 'all))
- (when rm-file-column
- ;; The file column is actually not wanted
- (forward-char 1)
- (org-table-delete-column))
total-time))
(defun org-clocktable-indent-string (level)
@@ -2718,26 +2690,26 @@ LEVEL is an integer. Indent by two spaces per level above 1."
(step (cdr (assoc step0 '((day . 86400) (week . 604800)))))
(stepskip0 (plist-get p1 :stepskip0))
(block (plist-get p1 :block))
- cc range-text step-time tsb)
+ cc step-time tsb)
(when block
(setq cc (org-clock-special-range block nil t ws ms)
- ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
+ ts (car cc)
+ te (nth 1 cc)))
(cond
((numberp ts)
- ;; If ts is a number, it's an absolute day number from org-agenda.
- (destructuring-bind (month day year) (calendar-gregorian-from-absolute ts)
- (setq ts (org-float-time (encode-time 0 0 0 day month year)))))
+ ;; If ts is a number, it's an absolute day number from
+ ;; org-agenda.
+ (pcase-let ((`(,month ,day ,year) (calendar-gregorian-from-absolute ts)))
+ (setq ts (float-time (encode-time 0 0 0 day month year)))))
(ts
- (setq ts (org-float-time
- (apply 'encode-time (org-parse-time-string ts))))))
+ (setq ts (float-time (apply #'encode-time (org-parse-time-string ts))))))
(cond
((numberp te)
;; Likewise for te.
- (destructuring-bind (month day year) (calendar-gregorian-from-absolute te)
- (setq te (org-float-time (encode-time 0 0 0 day month year)))))
+ (pcase-let ((`(,month ,day ,year) (calendar-gregorian-from-absolute te)))
+ (setq te (float-time (encode-time 0 0 0 day month year)))))
(te
- (setq te (org-float-time
- (apply 'encode-time (org-parse-time-string te))))))
+ (setq te (float-time (apply #'encode-time (org-parse-time-string te))))))
(setq tsb
(if (eq step0 'week)
(- ts (* 86400 (- (nth 6 (decode-time (seconds-to-time ts))) ws)))
@@ -2780,7 +2752,7 @@ following structure:
(LEVEL HEADLINE TIMESTAMP TIME)
LEVEL: The level of the headline, as an integer. This will be
- the reduced leve, so 1,2,3,... even if only odd levels
+ the reduced level, so 1,2,3,... even if only odd levels
are being used.
HEADLINE: The text of the headline. Depending on PARAMS, this may
already be formatted like a link.
@@ -2801,14 +2773,14 @@ TIME: The sum of all time spend in this tree, in minutes. This time
(tags (plist-get params :tags))
(properties (plist-get params :properties))
(inherit-property-p (plist-get params :inherit-props))
- todo-only
- (matcher (if tags (cdr (org-make-tags-matcher tags))))
- cc range-text st p time level hdl props tsp tbl)
+ (matcher (and tags (cdr (org-make-tags-matcher tags))))
+ cc st p time level hdl props tsp tbl)
(setq org-clock-file-total-minutes nil)
(when block
(setq cc (org-clock-special-range block nil t ws ms)
- ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
+ ts (car cc)
+ te (nth 1 cc)))
(when (integerp ts) (setq ts (calendar-gregorian-from-absolute ts)))
(when (integerp te) (setq te (calendar-gregorian-from-absolute te)))
(when (and ts (listp ts))
@@ -2820,12 +2792,12 @@ TIME: The sum of all time spend in this tree, in minutes. This time
(if te (setq te (org-matcher-time te)))
(save-excursion
(org-clock-sum ts te
- (unless (null matcher)
- (lambda ()
- (let* ((tags-list (org-get-tags-at))
- (org-scanner-tags tags-list)
- (org-trust-scanner-tags t))
- (eval matcher)))))
+ (when matcher
+ `(lambda ()
+ (let* ((tags-list (org-get-tags-at))
+ (org-scanner-tags tags-list)
+ (org-trust-scanner-tags t))
+ (funcall ,matcher nil tags-list nil)))))
(goto-char (point-min))
(setq st t)
(while (or (and (bobp) (prog1 st (setq st nil))
@@ -2837,7 +2809,7 @@ TIME: The sum of all time spend in this tree, in minutes. This time
(when (setq time (get-text-property p :org-clock-minutes))
(save-excursion
(beginning-of-line 1)
- (when (and (looking-at (org-re "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@#%:]+:\\)?[ \t]*$"))
+ (when (and (looking-at "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@#%:]+:\\)?[ \t]*$")
(setq level (org-reduced-level
(- (match-end 1) (match-beginning 1))))
(<= level maxlevel))
@@ -2852,7 +2824,7 @@ TIME: The sum of all time spend in this tree, in minutes. This time
(replace-regexp-in-string
org-bracket-link-regexp
(lambda (m) (or (match-string 3 m)
- (match-string 1 m)))
+ (match-string 1 m)))
(match-string 2)))))
tsp (when timestamp
(setq props (org-entry-properties (point)))
@@ -2930,10 +2902,10 @@ Otherwise, return nil."
(end-of-line 1)
(setq ts (match-string 1)
te (match-string 3))
- (setq s (- (org-float-time
- (apply 'encode-time (org-parse-time-string te)))
- (org-float-time