procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Update to Org 9.7.3

Browse source
This commit is contained in:
Kyle Meyer 2024-06-09 13:06:28 -04:00
parent e1cc2d1f61
commit 5a125fb5a9
123 changed files with 21824 additions and 12969 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2410
doc/misc/org.org
View file

File diff suppressed because it is too large Load diff

1697
etc/ORG-NEWS
View file

File diff suppressed because it is too large Load diff

23
etc/refcards/orgcard.tex
View file

@ -1,6 +1,6 @@
% Reference Card for Org Mode
\def\orgversionnumber{9.6.15}
\def\versionyear{2023} % latest update
\def\orgversionnumber{9.7.3}
\def\versionyear{2024} % latest update
\input emacsver.tex
%**start of header
@ -11,10 +11,14 @@
% Specify how many you want here.
\columnsperpage=3
% Set letterpaper to 0 for A4 paper, 1 for letter (US) paper. Useful
% only when columnsperpage is 2 or 3.
\letterpaper=1
% PDF output layout. 0 for A4, 1 for letter (US), a `l' is added for
% a landscape layout.
\input pdflayout.sty
\pdflayout=(0l)
\pdflayout=(1l)
% Nothing else needs to be changed below this line.
% Copyright (C) 1987, 1993, 1996--1997, 2001--2024 Free Software
@ -113,17 +117,14 @@
\footline{\hss\folio}
\def\makefootline{\baselineskip10pt\hsize6.5in\line{\the\footline}}
\else %2 or 3 columns uses prereduced size
\hsize 3.2in
\if 1\the\letterpaper
\hsize 3.2in
\vsize 7.95in
\hoffset -.75in
\voffset -.745in
\else
\hsize 3.2in
\vsize 7.65in
\hoffset -.25in
\voffset -.745in
\fi
\hoffset -.75in
\voffset -.745in
\font\titlefont=cmbx10 \scaledmag2
\font\headingfont=cmbx10 \scaledmag1
\font\smallfont=cmr6
@ -280,7 +281,7 @@
%**end of header
\title{Org-Mode Reference Card (1/2)}
\title{Org-Mode Reference Card}
\centerline{(for version \orgversionnumber)}
@ -482,7 +483,7 @@ \section{Completion and Template Insertion}
\newcolumn
\title{Org-Mode Reference Card (2/2)}
\title{Org-Mode Reference Card}
\centerline{(for version \orgversionnumber)}

57
lisp/org/ob-C.el
View file

@ -93,44 +93,45 @@ parameter may be used, like rdmd --chatty"
is currently being evaluated.")
(defun org-babel-execute:cpp (body params)
"Execute BODY according to PARAMS.
"Execute BODY according to its header arguments PARAMS.
This function calls `org-babel-execute:C++'."
(org-babel-execute:C++ body params))
(defun org-babel-expand-body:cpp (body params)
"Expand a block of C++ code with org-babel according to its header arguments."
"Expand C++ BODY with org-babel according to its header arguments PARAMS."
(org-babel-expand-body:C++ body params))
(defun org-babel-execute:C++ (body params)
"Execute a block of C++ code with org-babel.
"Execute C++ BODY with org-babel according to its header arguments PARAMS.
This function is called by `org-babel-execute-src-block'."
(let ((org-babel-c-variant 'cpp)) (org-babel-C-execute body params)))
(defun org-babel-expand-body:C++ (body params)
"Expand a block of C++ code with org-babel according to its header arguments."
"Expand C++ BODY with org-babel according to its header arguments PARAMS."
(let ((org-babel-c-variant 'cpp)) (org-babel-C-expand-C++ body params)))
(defun org-babel-execute:D (body params)
"Execute a block of D code with org-babel.
"Execute D BODY with org-babel according to its header arguments PARAMS.
This function is called by `org-babel-execute-src-block'."
(let ((org-babel-c-variant 'd)) (org-babel-C-execute body params)))
(defun org-babel-expand-body:D (body params)
"Expand a block of D code with org-babel according to its header arguments."
"Expand D BODY with org-babel according to its header arguments PARAMS."
(let ((org-babel-c-variant 'd)) (org-babel-C-expand-D body params)))
(defun org-babel-execute:C (body params)
"Execute a block of C code with org-babel.
"Execute a C BODY according to its header arguments PARAMS.
This function is called by `org-babel-execute-src-block'."
(let ((org-babel-c-variant 'c)) (org-babel-C-execute body params)))
(defun org-babel-expand-body:C (body params)
"Expand a block of C code with org-babel according to its header arguments."
"Expand C BODY according to its header arguments PARAMS."
(let ((org-babel-c-variant 'c)) (org-babel-C-expand-C body params)))
(defun org-babel-C-execute (body params)
"This function should only be called by `org-babel-execute:C'
or `org-babel-execute:C++' or `org-babel-execute:D'."
"Execute C/C++/D BODY according to its header arguments PARAMS.
This function should only be called by `org-babel-execute:C' or
`org-babel-execute:C++' or `org-babel-execute:D'."
(let* ((tmp-src-file (org-babel-temp-file
"C-src-"
(pcase org-babel-c-variant
@ -196,11 +197,11 @@ or `org-babel-execute:C++' or `org-babel-execute:D'."
)))
(defun org-babel-C-expand-C++ (body params)
"Expand a block of C/C++ code with org-babel according to its header arguments."
"Expand C/C++ BODY with according to its header arguments PARAMS."
(org-babel-C-expand-C body params))
(defun org-babel-C-expand-C (body params)
"Expand a block of C/C++ code with org-babel according to its header arguments."
"Expand C/C++ BODY according to its header arguments PARAMS."
(let ((vars (org-babel--get-vars params))
(colnames (cdr (assq :colname-names params)))
(main-p (not (string= (cdr (assq :main params)) "no")))
@ -212,7 +213,9 @@ or `org-babel-execute:C++' or `org-babel-execute:D'."
nil))
(namespaces (org-babel-read
(cdr (assq :namespaces params))
nil)))
nil))
(prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(when (stringp includes)
(setq includes (split-string includes)))
(when (stringp namespaces)
@ -226,6 +229,11 @@ or `org-babel-execute:C++' or `org-babel-execute:D'."
(nconc result (list (concat y " " x)))
(setq y nil)))
(setq defines (cdr result))))
(setq body
(concat
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n"))))
(mapconcat 'identity
(list
;; includes
@ -269,7 +277,7 @@ or `org-babel-execute:C++' or `org-babel-execute:D'."
body) "\n") "\n")))
(defun org-babel-C-expand-D (body params)
"Expand a block of D code with org-babel according to its header arguments."
"Expand D BODY according to its header arguments PARAMS."
(let ((vars (org-babel--get-vars params))
(colnames (cdr (assq :colname-names params)))
(main-p (not (string= (cdr (assq :main params)) "no")))
@ -313,13 +321,15 @@ or `org-babel-execute:C++' or `org-babel-execute:D'."
(format "int main() {\n%s\nreturn 0;\n}\n" body)))
(defun org-babel-prep-session:C (_session _params)
"This function does nothing as C is a compiled language with no
support for sessions."
"Throw and error that sessions are not supported.
This function does nothing as C is a compiled language with no support
for sessions."
(error "C is a compiled language -- no support for sessions"))
(defun org-babel-load-session:C (_session _body _params)
"This function does nothing as C is a compiled language with no
support for sessions."
"Throw and error that sessions are not supported.
This function does nothing as C is a compiled language with no support
for sessions."
(error "C is a compiled language -- no support for sessions"))
;; helper functions
@ -379,10 +389,11 @@ FORMAT can be either a format string or a function which is called with VAL."
type))))
(defun org-babel-C-val-to-base-type (val)
"Determine the base type of VAL which may be
`integerp' if all base values are integers
`floatp' if all base values are either floating points or integers
`stringp' otherwise."
"Determine the base type of VAL.
The type is:
- `integerp' if all base values are integers;
- `floatp' if all base values are either floating points or integers;
- `stringp' otherwise."
(cond
((integerp val) 'integerp)
((floatp val) 'floatp)
@ -401,7 +412,7 @@ FORMAT can be either a format string or a function which is called with VAL."
(t 'stringp)))
(defun org-babel-C-var-to-C (pair)
"Convert an elisp val into a string of C code specifying a var of the same value."
"Convert PAIR of (var . val) C variable assignment."
;; TODO list support
(let ((var (car pair))
(val (cdr pair)))

51
lisp/org/ob-R.el
View file

@ -64,6 +64,7 @@
(colormodel . :any)
(useDingbats . :any)
(horizontal . :any)
(async . ((yes no)))
(results . ((file list vector table scalar verbatim)
(raw html latex org code pp drawer)
(replace silent none append prepend)
@ -91,15 +92,6 @@ this variable.")
:version "24.1"
:type 'string)
(defvar ess-current-process-name) ; dynamically scoped
(defvar ess-local-process-name) ; dynamically scoped
(defun org-babel-edit-prep:R (info)
(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
;; package is not in the search path from R.
@ -156,7 +148,7 @@ This function is used when the table does not contain a header.")
"\n"))
(defun org-babel-execute:R (body params)
"Execute a block of R code.
"Execute a block of R code BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(save-excursion
(let* ((result-params (cdr (assq :result-params params)))
@ -215,7 +207,8 @@ This function is called by `org-babel-execute-src-block'."
;; helper functions
(defun org-babel-variable-assignments:R (params)
"Return list of R statements assigning the block's variables."
"Return list of R statements assigning the block's variables.
Retrieve variables from PARAMS."
(let ((vars (org-babel--get-vars params)))
(mapcar
(lambda (pair)
@ -261,42 +254,44 @@ This function is called by `org-babel-execute-src-block'."
(t (format "%s <- %S" name (prin1-to-string value))))))
(defvar ess-current-process-name) ; dynamically scoped
(defvar ess-local-process-name) ; dynamically scoped
(defvar ess-ask-for-ess-directory) ; dynamically scoped
(defvar ess-gen-proc-buffer-name-function) ; defined in ess-inf.el
(defun org-babel-R-initiate-session (session params)
"If there is not a current R process then create one."
"Create or return the current R SESSION buffer.
Use PARAMS to set default directory when creating a new session."
(unless (string= session "none")
(let ((session (or session "*R*"))
(ess-ask-for-ess-directory
(and (boundp 'ess-ask-for-ess-directory)
ess-ask-for-ess-directory
(not (cdr (assq :dir params))))))
(let* ((session (or session "*R*"))
(ess-ask-for-ess-directory
(and (boundp 'ess-ask-for-ess-directory)
ess-ask-for-ess-directory
(not (cdr (assq :dir params)))))
;; Make ESS name the process buffer as SESSION.
(ess-gen-proc-buffer-name-function
(lambda (_) session)))
(if (org-babel-comint-buffer-livep session)
session
(save-window-excursion
(when (get-buffer session)
;; Session buffer exists, but with dead process
(set-buffer session))
(require 'ess-r-mode)
(org-require-package 'ess-r-mode "ESS")
(set-buffer (run-ess-r))
(let ((R-proc (get-process (or ess-local-process-name
ess-current-process-name))))
(while (process-get R-proc 'callbacks)
(ess-wait-for-process R-proc)))
(rename-buffer
(if (bufferp session)
(buffer-name session)
(if (stringp session)
session
(buffer-name))))
(current-buffer))))))
(defun org-babel-R-associate-session (session)
"Associate R code buffer with an R session.
Make SESSION be the inferior ESS process associated with the
current code buffer."
(setq ess-local-process-name
(process-name (get-buffer-process session)))
(ess-make-buffer-current))
(when-let ((process (get-buffer-process session)))
(setq ess-local-process-name (process-name process))
(ess-make-buffer-current))
(setq-local ess-gen-proc-buffer-name-function (lambda (_) session)))
(defvar org-babel-R-graphics-devices
'((:bmp "bmp" "filename")
@ -520,7 +515,7 @@ by `org-babel-comint-async-filter'."
(ess-eval-buffer nil)))
tmp-file))
(output
(let ((uuid (md5 (number-to-string (random 100000000))))
(let ((uuid (org-id-uuid))
(ess-local-process-name
(process-name (get-buffer-process session)))
(ess-eval-visibly-p nil))

16
lisp/org/ob-awk.el
View file

@ -48,12 +48,18 @@
(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)
(let ((prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(concat
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n")))))
(defun org-babel-execute:awk (body params)
"Execute a block of Awk code with org-babel.
"Execute a block of Awk code BODY with org-babel.
PARAMS is a plist of src block parameters .
This function is called by `org-babel-execute-src-block'."
(message "Executing Awk source code block")
(let* ((result-params (cdr (assq :result-params params)))
@ -100,7 +106,9 @@ This function is called by `org-babel-execute-src-block'."
(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."
"Return a printed value of VAR suitable for parsing with awk.
SEP, when non-nil is a separator used when converting list values to awk
table."
(let ((echo-var (lambda (v) (if (stringp v) v (format "%S" v)))))
(cond
((and (listp var) (listp (car var)))

32
lisp/org/ob-calc.el
View file

@ -44,13 +44,19 @@
(defvar org-babel-default-header-args:calc nil
"Default arguments for evaluating a calc source block.")
(defun org-babel-expand-body:calc (body _params)
"Expand BODY according to PARAMS, return the expanded body." body)
(defun org-babel-expand-body:calc (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(concat
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n")))))
(defvar org--var-syms) ; Dynamically scoped from org-babel-execute:calc
(defun org-babel-execute:calc (body params)
"Execute a block of calc code with Babel."
"Execute BODY of calc code with Babel using PARAMS."
(unless (get-buffer "*Calculator*")
(save-window-excursion (calc) (calc-quit)))
(let* ((vars (org-babel--get-vars params))
@ -58,7 +64,23 @@
(var-names (mapcar #'symbol-name org--var-syms)))
(mapc
(lambda (pair)
(calc-push-list (list (cdr pair)))
(let ((val (cdr pair)))
(calc-push-list
(list
(cond
;; For a vector, Calc follows the format (vec 1 2 3 ...) so
;; a matrix becomes (vec (vec 1 2 3) (vec 4 5 6) ...). See
;; the comments in "Arithmetic routines." section of
;; calc.el.
((listp val)
(cons 'vec
(if (null (cdr val))
(car val)
(mapcar (lambda (x) (if (listp x) (cons 'vec x) x))
val))))
((numberp val)
(math-read-number (number-to-string val)))
(t val)))))
(calc-store-into (car pair)))
vars)
(mapc
@ -99,6 +121,8 @@
(calc-pop 1)))))
(defun org-babel-calc-maybe-resolve-var (el)
"Resolve user variables in EL.
EL is taken from the output of `math-read-exprs'."
(if (consp el)
(if (and (eq 'var (car el)) (member (cadr el) org--var-syms))
(progn

172
lisp/org/ob-clojure.el
View file

@ -25,20 +25,21 @@
;;; Commentary:
;; Support for evaluating Clojure code
;; Support for evaluating Clojure / ClojureScript code.
;; Requirements:
;; - Clojure (at least 1.2.0)
;; - clojure-mode
;; - inf-clojure, Cider, SLIME, babashka or nbb
;; - babashka, nbb, Clojure CLI tools, Cider, inf-clojure or SLIME
;; For clojure-mode, see https://github.com/clojure-emacs/clojure-mode
;; For inf-clojure, see https://github.com/clojure-emacs/inf-clojure
;; For Cider, see https://github.com/clojure-emacs/cider
;; For SLIME, see https://slime.common-lisp.dev
;; For babashka, see https://github.com/babashka/babashka
;; For nbb, see https://github.com/babashka/nbb
;; For Clojure CLI tools, see https://clojure.org/guides/deps_and_cli
;; For Cider, see https://github.com/clojure-emacs/cider
;; For inf-clojure, see https://github.com/clojure-emacs/inf-clojure
;; For SLIME, see https://slime.common-lisp.dev
;; For SLIME, the best way to install its components is by following
;; the directions as set out by Phil Hagelberg (Technomancy) on the
@ -78,20 +79,33 @@
(defcustom org-babel-clojure-backend (cond
((executable-find "bb") 'babashka)
((executable-find "nbb") 'nbb)
((executable-find "clojure") 'clojure-cli)
((featurep 'cider) 'cider)
((featurep 'inf-clojure) 'inf-clojure)
((featurep 'slime) 'slime)
(t nil))
"Backend used to evaluate Clojure code blocks."
:group 'org-babel
:package-version '(Org . "9.6")
:package-version '(Org . "9.7")
:type '(choice
(const :tag "inf-clojure" inf-clojure)
(const :tag "cider" cider)
(const :tag "slime" slime)
(const :tag "babashka" babashka)
(const :tag "clojure-cli" clojure-cli)
(const :tag "cider" cider)
(const :tag "inf-clojure" inf-clojure)
(const :tag "slime" slime)
(const :tag "Not configured yet" nil)))
(defcustom org-babel-clojurescript-backend
(cond
((or (executable-find "nbb") (executable-find "npx")) 'nbb)
((featurep 'cider) 'cider)
(t nil))
"Backend used to evaluate ClojureScript code blocks."
:group 'org-babel
:package-version '(Org . "9.7")
:type '(choice
(const :tag "nbb" nbb)
(const :tag "cider" cider)
(const :tag "Not configured yet" nil)))
(defcustom org-babel-clojure-default-ns "user"
@ -100,19 +114,29 @@
:group 'org-babel)
(defcustom ob-clojure-babashka-command (executable-find "bb")
"Path to the babashka executable."
"Babashka command used by the Clojure `babashka' backend."
:type '(choice file (const nil))
:group 'org-babel
:package-version '(Org . "9.6"))
(defcustom ob-clojure-nbb-command (executable-find "nbb")
"Path to the nbb executable."
:type '(choice file (const nil))
(defcustom ob-clojure-nbb-command (or (executable-find "nbb")
(when-let (npx (executable-find "npx"))
(concat npx " nbb")))
"Nbb command used by the ClojureScript `nbb' backend."
:type '(choice string (const nil))
:group 'org-babel
:package-version '(Org . "9.6"))
:package-version '(Org . "9.7"))
(defun org-babel-expand-body:clojure (body params)
"Expand BODY according to PARAMS, return the expanded body."
(defcustom ob-clojure-cli-command (when-let (cmd (executable-find "clojure"))
(concat cmd " -M"))
"Clojure CLI command used by the Clojure `clojure-cli' backend."
:type 'string
:group 'org-babel
:package-version '(Org . "9.7"))
(defun org-babel-expand-body:clojure (body params &optional cljs-p)
"Expand BODY according to PARAMS, return the expanded body.
When CLJS-P is non-nil, expand in a cljs context instead of clj."
(let* ((vars (org-babel--get-vars params))
(backend-override (cdr (assq :backend params)))
(org-babel-clojure-backend
@ -146,10 +170,26 @@ or set the `:backend' header argument"))))
vars
"\n ")
body))))))
(if (or (member "code" result-params)
(member "pp" result-params))
(format "(clojure.pprint/pprint (do %s))" body)
body)))
;; If the result param is set to "output" we don't have to do
;; anything special and just let the backend handle everything
(if (member "output" result-params)
body
;; If the result is not "output" (i.e. it's "value"), disable
;; stdout output and print the last returned value. Use pprint
;; instead of prn when results param is "pp" or "code".
(concat
(if (or (member "code" result-params)
(member "pp" result-params))
(concat (if cljs-p
"(require '[cljs.pprint :refer [pprint]])"
"(require '[clojure.pprint :refer [pprint]])")
" (pprint ")
"(prn ")
(if cljs-p
"(binding [cljs.core/*print-fn* (constantly nil)]"
"(binding [*out* (java.io.StringWriter.)]")
body "))"))))
(defvar ob-clojure-inf-clojure-filter-out)
(defvar ob-clojure-inf-clojure-tmp-output)
@ -186,8 +226,7 @@ or set the `:backend' header argument"))))
(defvar inf-clojure-comint-prompt-regexp)
(defun ob-clojure-eval-with-inf-clojure (expanded params)
"Evaluate EXPANDED code block with PARAMS using inf-clojure."
(condition-case nil (require 'inf-clojure)
(user-error "inf-clojure not available"))
(org-require-package 'inf-clojure)
;; Maybe initiate the inf-clojure session
(unless (and inf-clojure-buffer
(buffer-live-p (get-buffer inf-clojure-buffer)))
@ -198,7 +237,9 @@ or set the `:backend' header argument"))))
"clojure" (format "clojure -A%s" alias)
cmd0)
cmd0)))
(setq comint-prompt-regexp inf-clojure-comint-prompt-regexp)
(setq
org-babel-comint-prompt-regexp-old comint-prompt-regexp
comint-prompt-regexp inf-clojure-comint-prompt-regexp)
(funcall-interactively #'inf-clojure cmd)
(goto-char (point-max))))
(sit-for 1))
@ -226,38 +267,24 @@ or set the `:backend' header argument"))))
s))
(reverse ob-clojure-inf-clojure-tmp-output)))))
(defun ob-clojure-eval-with-cider (expanded params)
"Evaluate EXPANDED code block with PARAMS using cider."
(condition-case nil (require 'cider)
(user-error "cider not available"))
(let ((connection (cider-current-connection (cdr (assq :target params))))
(result-params (cdr (assq :result-params params)))
result0)
(defun ob-clojure-eval-with-cider (expanded _params &optional cljs-p)
"Evaluate EXPANDED code block using cider.
When CLJS-P is non-nil, use a cljs connection instead of clj.
The PARAMS from Babel are not used in this function."
(org-require-package 'cider "Cider")
(let ((connection (cider-current-connection (if cljs-p "cljs" "clj"))))
(unless connection (sesman-start-session 'CIDER))
(if (not connection)
;; Display in the result instead of using `user-error'
(setq result0 "Please reevaluate when nREPL is connected")
(ob-clojure-with-temp-expanded expanded params
(let ((response (nrepl-sync-request:eval exp connection)))
(push (or (nrepl-dict-get response "root-ex")
(nrepl-dict-get response "ex")
(nrepl-dict-get
response (if (or (member "output" result-params)
(member "pp" result-params))
"out"
"value")))
result0)))
(ob-clojure-string-or-list
;; Filter out s-expressions that return nil (string "nil"
;; from nrepl eval) or comment forms (actual nil from nrepl)
(reverse (delete "" (mapcar (lambda (r)
(replace-regexp-in-string "nil" "" (or r "")))
result0)))))))
"Please reevaluate when nREPL is connected"
(let ((response (nrepl-sync-request:eval expanded connection)))
(or (nrepl-dict-get response "root-ex")
(nrepl-dict-get response "ex")
(nrepl-dict-get response "out"))))))
(defun ob-clojure-eval-with-slime (expanded params)
"Evaluate EXPANDED code block with PARAMS using slime."
(condition-case nil (require 'slime)
(user-error "slime not available"))
(org-require-package 'slime "SLIME")
(with-temp-buffer
(insert expanded)
(slime-eval
@ -265,39 +292,54 @@ or set the `:backend' header argument"))))
,(buffer-substring-no-properties (point-min) (point-max)))
(cdr (assq :package params)))))
(defun ob-clojure-eval-with-babashka (bb expanded)
"Evaluate EXPANDED code block using BB (babashka or nbb)."
(let ((script-file (org-babel-temp-file "clojure-bb-script-" ".clj")))
(defun ob-clojure-eval-with-cmd (cmd expanded)
"Evaluate EXPANDED code block using CMD (babashka, clojure or nbb)."
(let ((script-file (org-babel-temp-file "clojure-cmd-script-" ".clj")))
(with-temp-file script-file
(insert expanded))
(org-babel-eval
(format "%s %s" bb (org-babel-process-file-name script-file))
(format "%s %s" cmd (org-babel-process-file-name script-file))
"")))
(defun org-babel-execute:clojure (body params)
"Execute the BODY block of Clojure code with PARAMS using Babel."
(defun org-babel-execute:clojure (body params &optional cljs-p)
"Execute the BODY block of Clojure code with PARAMS using Babel.
When CLJS-P is non-nil, execute with a ClojureScript backend
instead of Clojure."
(let* ((backend-override (cdr (assq :backend params)))
(org-babel-clojure-backend
(cond
(backend-override (intern backend-override))
(org-babel-clojure-backend org-babel-clojure-backend)
(t (user-error "You need to customize `org-babel-clojure-backend'
or set the `:backend' header argument")))))
(let* ((expanded (org-babel-expand-body:clojure body params))
(org-babel-clojure-backend (if cljs-p
org-babel-clojurescript-backend
org-babel-clojure-backend))
(t (user-error "You need to customize `%S'
or set the `:backend' header argument"
(if cljs-p
org-babel-clojurescript-backend
org-babel-clojure-backend)))))
;; We allow a Clojure source block to be evaluated with the
;; nbb backend and therefore have to expand the body with
;; ClojureScript syntax when we either evaluate a
;; ClojureScript source block or use the nbb backend.
(cljs-p (or cljs-p (eq org-babel-clojure-backend 'nbb))))
(let* ((expanded (org-babel-expand-body:clojure body params cljs-p))
(result-params (cdr (assq :result-params params)))
result)
(setq result
(cond
((eq org-babel-clojure-backend 'inf-clojure)
(ob-clojure-eval-with-inf-clojure expanded params))
((eq org-babel-clojure-backend 'clojure-cli)
(ob-clojure-eval-with-cmd ob-clojure-cli-command expanded))
((eq org-babel-clojure-backend 'babashka)
(ob-clojure-eval-with-babashka ob-clojure-babashka-command expanded))
(ob-clojure-eval-with-cmd ob-clojure-babashka-command expanded))
((eq org-babel-clojure-backend 'nbb)
(ob-clojure-eval-with-babashka ob-clojure-nbb-command expanded))
(ob-clojure-eval-with-cmd ob-clojure-nbb-command expanded))
((eq org-babel-clojure-backend 'cider)
(ob-clojure-eval-with-cider expanded params))
(ob-clojure-eval-with-cider expanded params cljs-p))
((eq org-babel-clojure-backend 'slime)
(ob-clojure-eval-with-slime expanded params))))
(ob-clojure-eval-with-slime expanded params))
(t (user-error "Invalid backend"))))
(org-babel-result-cond result-params
result
(condition-case nil (org-babel-script-escape result)
@ -305,7 +347,7 @@ or set the `:backend' header argument")))))
(defun org-babel-execute:clojurescript (body params)
"Evaluate BODY with PARAMS as ClojureScript code."
(org-babel-execute:clojure body (cons '(:target . "cljs") params)))
(org-babel-execute:clojure body params t))
(provide 'ob-clojure)

149
lisp/org/ob-comint.el
View file

@ -58,6 +58,48 @@ executed inside the protection of `save-excursion' and
(let ((comint-input-filter (lambda (_input) nil)))
,@body))))))
(defvar-local org-babel-comint-prompt-regexp-old nil
"Fallback regexp used to detect prompt.")
(defcustom org-babel-comint-fallback-regexp-threshold 5.0
"Waiting time until trying to use fallback regexp to detect prompt.
This is useful when prompt unexpectedly changes."
:type 'float
:group 'org-babel
:package-version '(Org . "9.7"))
(defun org-babel-comint--set-fallback-prompt ()
"Swap `comint-prompt-regexp' and `org-babel-comint-prompt-regexp-old'."
(when org-babel-comint-prompt-regexp-old
(let ((tmp comint-prompt-regexp))
(setq comint-prompt-regexp org-babel-comint-prompt-regexp-old
org-babel-comint-prompt-regexp-old tmp))))
(defun org-babel-comint--prompt-filter (string &optional prompt-regexp)
"Remove PROMPT-REGEXP from STRING.
PROMPT-REGEXP defaults to `comint-prompt-regexp'."
(let* ((prompt-regexp (or prompt-regexp comint-prompt-regexp))
;; We need newline in case if we do progressive replacement
;; of agglomerated comint prompts with `comint-prompt-regexp'
;; containing ^.
(separator "org-babel-comint--prompt-filter-separator\n"))
(while (string-match-p prompt-regexp string)
(setq string
(replace-regexp-in-string
(format "\\(?:%s\\)?\\(?:%s\\)[ \t]*" separator prompt-regexp)
separator string)))
(delete "" (split-string string separator))))
(defun org-babel-comint--echo-filter (string &optional echo)
"Remove ECHO from STRING."
(and echo string
(string-match
(replace-regexp-in-string "\n" "[\r\n]+" (regexp-quote echo))
string)
(setq string (substring string (match-end 0))))
string)
(defmacro org-babel-comint-with-output (meta &rest body)
"Evaluate BODY in BUFFER and return process output.
Will wait until EOE-INDICATOR appears in the output, then return
@ -74,9 +116,7 @@ or user `keyboard-quit' during execution of body."
(let ((buffer (nth 0 meta))
(eoe-indicator (nth 1 meta))
(remove-echo (nth 2 meta))
(full-body (nth 3 meta))
(org-babel-comint-prompt-separator
"org-babel-comint-prompt-separator"))
(full-body (nth 3 meta)))
`(org-babel-comint-in-buffer ,buffer
(let* ((string-buffer "")
(comint-output-filter-functions
@ -93,43 +133,39 @@ or user `keyboard-quit' during execution of body."
;; pass FULL-BODY to process
,@body
;; wait for end-of-evaluation indicator
(while (progn
(goto-char comint-last-input-end)
(not (save-excursion
(and (re-search-forward
(regexp-quote ,eoe-indicator) nil t)
(re-search-forward
comint-prompt-regexp nil t)))))
(accept-process-output (get-buffer-process (current-buffer))))
(let ((start-time (current-time)))
(while (progn
(goto-char comint-last-input-end)
(not (save-excursion
(and (re-search-forward
(regexp-quote ,eoe-indicator) nil t)
(re-search-forward
comint-prompt-regexp nil t)))))
(accept-process-output
(get-buffer-process (current-buffer))
org-babel-comint-fallback-regexp-threshold)
(when (and org-babel-comint-prompt-regexp-old
(> (float-time (time-since start-time))
org-babel-comint-fallback-regexp-threshold)
(progn
(goto-char comint-last-input-end)
(save-excursion
(and
(re-search-forward
(regexp-quote ,eoe-indicator) nil t)
(re-search-forward
org-babel-comint-prompt-regexp-old nil t)))))
(org-babel-comint--set-fallback-prompt))))
;; replace cut dangling text
(goto-char (process-mark (get-buffer-process (current-buffer))))
(insert dangling-text)
;; remove echo'd FULL-BODY from input
(and ,remove-echo ,full-body
(setq string-buffer (org-babel-comint--echo-filter string-buffer ,full-body)))
;; Filter out prompts.
(setq string-buffer
(replace-regexp-in-string
;; Sometimes, we get multiple agglomerated
;; prompts together in a single output:
;; "prompt prompt prompt output"
;; Remove them progressively, so that
;; possible "^" in the prompt regexp gets to
;; work as we remove the heading prompt
;; instance.
(if (string-prefix-p "^" comint-prompt-regexp)
(format "^\\(%s\\)+" (substring comint-prompt-regexp 1))
comint-prompt-regexp)
,org-babel-comint-prompt-separator
string-buffer))
;; remove echo'd FULL-BODY from input
(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))))
(delete "" (split-string
string-buffer
,org-babel-comint-prompt-separator))))))
(org-babel-comint--prompt-filter string-buffer)))))
(defun org-babel-comint-input-command (buffer cmd)
"Pass CMD to BUFFER.
@ -145,11 +181,23 @@ The input will not be echoed."
Note: this is only safe when waiting for the result of a single
statement (not large blocks of code)."
(org-babel-comint-in-buffer buffer
(while (progn
(goto-char comint-last-input-end)
(not (and (re-search-forward comint-prompt-regexp nil t)
(goto-char (match-beginning 0)))))
(accept-process-output (get-buffer-process buffer)))))
(let ((start-time (current-time)))
(while (progn
(goto-char comint-last-input-end)
(not (and (re-search-forward comint-prompt-regexp nil t)
(goto-char (match-beginning 0)))))
(accept-process-output
(get-buffer-process buffer)
org-babel-comint-fallback-regexp-threshold)
(when (and org-babel-comint-prompt-regexp-old
(> (float-time (time-since start-time))
org-babel-comint-fallback-regexp-threshold)
(progn
(goto-char comint-last-input-end)
(save-excursion
(re-search-forward
org-babel-comint-prompt-regexp-old nil t))))
(org-babel-comint--set-fallback-prompt))))))
(defun org-babel-comint-eval-invisibly-and-wait-for-file
(buffer file string &optional period)
@ -192,8 +240,8 @@ comint process. It should return a string that will be passed
to `org-babel-insert-result'.")
(defvar-local org-babel-comint-async-dangling nil
"Dangling piece of the last process output, in case
`org-babel-comint-async-indicator' is spread across multiple
"Dangling piece of the last process output, as a string.
Used when `org-babel-comint-async-indicator' is spread across multiple
comint outputs due to buffering.")
(defun org-babel-comint-use-async (params)
@ -221,6 +269,8 @@ STRING contains the output originally inserted into the comint buffer."
(file-callback org-babel-comint-async-file-callback)
(combined-string (concat org-babel-comint-async-dangling string))
(new-dangling combined-string)
;; Assumes comint filter called with session buffer current
(session-dir default-directory)
;; list of UUID's matched by `org-babel-comint-async-indicator'
uuid-list)
(with-temp-buffer
@ -245,7 +295,8 @@ STRING contains the output originally inserted into the comint buffer."
(let* ((info (org-babel-get-src-block-info))
(params (nth 2 info))
(result-params
(cdr (assq :result-params params))))
(cdr (assq :result-params params)))
(default-directory session-dir))
(org-babel-insert-result
(funcall file-callback
(nth
@ -268,16 +319,17 @@ STRING contains the output originally inserted into the comint buffer."
(res-str-raw
(buffer-substring
;; move point to beginning of indicator
(- (match-beginning 0) 1)
(match-beginning 0)
;; find the matching start indicator
(cl-loop
do (re-search-backward indicator)
until (and (equal (match-string 1) "start")
(equal (match-string 2) uuid))
finally return (+ 1 (match-end 0)))))
;; Apply callback to clean up the result
(res-str (funcall org-babel-comint-async-chunk-callback
res-str-raw)))
;; Remove prompt
(res-promptless (org-trim (string-join (mapcar #'org-trim (org-babel-comint--prompt-filter res-str-raw)) "\n") "\n"))
;; Apply user callback
(res-str (funcall org-babel-comint-async-chunk-callback res-promptless)))
;; Search for uuid in associated org-buffers to insert results
(cl-loop for buf in org-buffers
until (with-current-buffer buf
@ -288,7 +340,8 @@ STRING contains the output originally inserted into the comint buffer."
(let* ((info (org-babel-get-src-block-info))
(params (nth 2 info))
(result-params
(cdr (assq :result-params params))))
(cdr (assq :result-params params)))
(default-directory session-dir))
(org-babel-insert-result
res-str result-params info))
t))))

640
lisp/org/ob-core.el
View file

File diff suppressed because it is too large Load diff

2
lisp/org/ob-css.el
View file

@ -36,7 +36,7 @@
(defvar org-babel-default-header-args:css '())
(defun org-babel-execute:css (body _params)
"Execute a block of CSS code.
"Execute BODY of CSS code.
This function is called by `org-babel-execute-src-block'."
body)

4
lisp/org/ob-ditaa.el
View file

@ -83,11 +83,11 @@ Do not leave leading or trailing spaces in this string."
:type 'string)
(defun org-babel-execute:ditaa (body params)
"Execute a block of Ditaa code with org-babel.
"Execute BODY of Ditaa code with org-babel according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let* ((out-file (or (cdr (assq :file params))
(error
"ditaa code block requires :file header argument")))
"Ditaa code block requires :file header argument")))
(cmdline (cdr (assq :cmdline params)))
(java (cdr (assq :java params)))
(in-file (org-babel-temp-file "ditaa-"))

11
lisp/org/ob-dot.el
View file

@ -51,7 +51,9 @@
(defun org-babel-expand-body:dot (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (org-babel--get-vars params)))
(let ((vars (org-babel--get-vars params))
(prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
@ -64,10 +66,13 @@
t
t))))
vars)
body))
(concat
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n")))))
(defun org-babel-execute:dot (body params)
"Execute a block of Dot code with org-babel.
"Execute Dot BODY with org-babel according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let* ((out-file (cdr (or (assq :file params)
(error "You need to specify a :file parameter"))))

22
lisp/org/ob-emacs-lisp.el
View file

@ -53,18 +53,23 @@ by `org-edit-src-code'.")
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (org-babel--get-vars params))
(print-level nil)
(print-length nil))
(print-length nil)
(prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(if (null vars) (concat body "\n")
(format "(let (%s)\n%s\n)"
(format "(let (%s)\n%s%s%s\n)"
(mapconcat
(lambda (var)
(format "%S" `(,(car var) ',(cdr var))))
vars "\n ")
body))))
(if prologue (concat prologue "\n ") "")
body
(if epilogue (concat "\n " epilogue "\n") "")))))
(defun org-babel-execute:emacs-lisp (body params)
"Execute a block of emacs-lisp code with Babel."
"Execute emacs-lisp code BODY according to PARAMS."
(let* ((lexical (cdr (assq :lexical params)))
(session (cdr (assq :session params)))
(result-params (cdr (assq :result-params params)))
(body (format (if (member "output" result-params)
"(with-output-to-string %s\n)"
@ -75,6 +80,8 @@ by `org-edit-src-code'.")
(concat "(pp " body ")")
body))
(org-babel-emacs-lisp-lexical lexical))))
(when (and session (not (equal session "none")))
(error "ob-emacs-lisp backend does not support sessions"))
(org-babel-result-cond result-params
(let ((print-level nil)
(print-length nil))
@ -100,12 +107,17 @@ and the LEXICAL argument to `eval'."
(defun org-babel-edit-prep:emacs-lisp (info)
"Set `lexical-binding' in Org edit buffer.
Set `lexical-binding' in Org edit buffer according to the
corresponding :lexical source block argument."
corresponding :lexical source block argument provide in the INFO
channel, as returned by `org-babel-get-src-block-info'."
(setq lexical-binding
(org-babel-emacs-lisp-lexical
(org-babel-read
(cdr (assq :lexical (nth 2 info)))))))
(defun org-babel-prep-session:emacs-lisp (_session _params)
"Return an error because we do not support sessions."
(error "ob-emacs-lisp backend does not support sessions"))
(org-babel-make-language-alias "elisp" "emacs-lisp")
(provide 'ob-emacs-lisp)

5
lisp/org/ob-eshell.el
View file

@ -95,10 +95,11 @@ The PARAMS argument is passed to
session))
(defun org-babel-variable-assignments:eshell (params)
"Convert ob-eshell :var specified variables into Eshell variables assignments."
"Convert ob-eshell variables from PARAMS into Eshell variables assignments."
(mapcar
(lambda (pair)
(format "(setq %s %S)" (car pair) (cdr pair)))
;; Use `ignore' to suppress value in the command output.
(format "(ignore (setq %s %S))" (car pair) (cdr pair)))
(org-babel--get-vars params)))
(defun org-babel-load-session:eshell (session body params)

17
lisp/org/ob-eval.el
View file

@ -37,16 +37,21 @@
(declare-function org-babel-temp-file "ob-core" (prefix &optional suffix))
(defun org-babel-eval-error-notify (exit-code stderr)
"Open a buffer to display STDERR and a message with the value of EXIT-CODE."
"Open a buffer to display STDERR and a message with the value of EXIT-CODE.
If EXIT-CODE is nil, display the message without a code."
(let ((buf (get-buffer-create org-babel-error-buffer-name)))
(with-current-buffer buf
(goto-char (point-max))
(save-excursion
(unless (bolp) (insert "\n"))
(insert stderr)
(insert (format "[ Babel evaluation exited with code %S ]" exit-code))))
(if exit-code
(insert (format "[ Babel evaluation exited with code %S ]" exit-code))
(insert "[ Babel evaluation exited abnormally ]"))))
(display-buffer buf))
(message "Babel evaluation exited with code %S" exit-code))
(if exit-code
(message "Babel evaluation exited with code %S" exit-code)
(message "Babel evaluation exited abnormally")))
(defun org-babel-eval (command query)
"Run COMMAND on QUERY.
@ -59,6 +64,7 @@ Writes QUERY into a temp-buffer that is processed with
(let ((error-buffer (get-buffer-create " *Org-Babel Error*")) exit-code)
(with-current-buffer error-buffer (erase-buffer))
(with-temp-buffer
;; Ensure trailing newline. It is required for cmdproxy.exe.
(insert query "\n")
(setq exit-code
(org-babel--shell-command-on-region
@ -100,11 +106,6 @@ returned."
(error-file (if error-buffer (org-babel-temp-file "ob-error-") nil))
(shell-file-name (org-babel--get-shell-file-name))
exit-status)
;; There is an error in `process-file' when `error-file' exists.
;; This is fixed in Emacs trunk as of 2012-12-21; let's use this
;; workaround for now.
(unless (file-remote-p default-directory)
(delete-file error-file))
;; we always call this with 'replace, remove conditional
;; Replace specified region with output from command.
(org-babel--write-temp-buffer-input-file input-file)

444
lisp/org/ob-exp.el
View file

@ -32,8 +32,10 @@
(declare-function org-babel-lob-get-info "ob-lob" (&optional datum no-eval))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(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-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-escape-code-in-string "org-src" (s))
(declare-function org-export-copy-buffer "ox"
(&optional buffer drop-visibility
@ -41,8 +43,7 @@
drop-locals))
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance element))
(declare-function org-in-archived-heading-p "org" (&optional no-inheritance element))
(defvar org-src-preserve-indentation)
(declare-function org-src-preserve-indentation-p "org-src" (node))
(defcustom org-export-use-babel t
"Switch controlling code evaluation and header processing during export.
@ -140,217 +141,236 @@ this template."
"Execute all Babel blocks in current buffer."
(interactive)
(when org-export-use-babel
(save-window-excursion
(let ((case-fold-search t)
(regexp "\\(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))
element)
(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))
(let ((case-fold-search t)
(regexp "\\(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))
element)
(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))
;; We are about to do a large number of changes in
;; buffer, but we do not care about folding in this
;; buffer.
(org-fold-core-ignore-modifications
(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))
;; We are about to do a large number of changes in
;; buffer, but we do not care about folding in this
;; buffer.
(org-fold-core-ignore-modifications
(while (re-search-forward regexp nil t)
(setq element (org-element-at-point))
(unless (save-match-data
(or (org-in-commented-heading-p nil element)
(org-in-archived-heading-p nil element)))
(let* ((object? (match-end 1))
(element (save-match-data
(if object?
(org-element-context element)
;; No deep inspection if we're
;; just looking for an element.
element)))
(type
(pcase (org-element-type element)
;; Discard block elements if we're looking
;; for inline objects. False results
;; happen when, e.g., "call_" syntax is
;; located within affiliated keywords:
;;
;; #+name: call_src
;; #+begin_src ...
((and (or `babel-call `src-block) (guard object?))
nil)
(type type)))
(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 source block
;; but preserve following white spaces.
;; Then insert value.
(unless (string= replacement
(buffer-substring begin end))
(delete-region begin end)
(insert replacement))))))
((or `babel-call `inline-babel-call)
(org-babel-exp-do-export
(or (org-babel-lob-get-info element)
(user-error "Unknown Babel reference: %s"
(org-element-property :call 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)
(setq element (save-match-data (org-element-at-point)))
(unless (save-match-data
(or (org-in-commented-heading-p nil element)
(org-in-archived-heading-p nil element)))
(let* ((object? (match-end 1))
(element (save-match-data
(if object?
(org-element-context element)
;; No deep inspection if we're
;; just looking for an element.
element)))
(type
(pcase (org-element-type element)
;; Discard block elements if we're looking
;; for inline objects. False results
;; happen when, e.g., "call_" syntax is
;; located within affiliated keywords:
;;
;; #+name: call_src
;; #+begin_src ...
((and (or `babel-call `src-block) (guard object?))
nil)
(type type)))
(begin
(copy-marker (org-element-begin element)))
(end
(copy-marker
(save-excursion
(goto-char (org-element-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)))
(cond
((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))))
((not replacement)
;; Replacement code cannot be determined.
;; Leave the code block as is.
(goto-char end))
;; Otherwise: remove inline source block
;; but preserve following white spaces.
;; Then insert value.
((not (string= replacement
(buffer-substring begin end)))
(delete-region begin end)
(insert rep))))
(`src-block
(let ((match-start (copy-marker (match-beginning 0)))
(ind (org-current-text-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 element))))
(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
(if (or org-src-preserve-indentation
(org-element-property
:preserve-indent element))
;; Indent only code block
;; markers.
(with-temp-buffer
;; Do not use tabs for block
;; indentation.
(when (fboundp 'indent-tabs-mode)
(indent-tabs-mode -1)
;; FIXME: Emacs 26
;; compatibility.
(setq-local indent-tabs-mode nil))
(insert replacement)
(skip-chars-backward " \r\t\n")
(indent-line-to ind)
(goto-char 1)
(indent-line-to ind)
(setq replacement (buffer-string)))
;; Indent everything.
(with-temp-buffer
;; Do not use tabs for block
;; indentation.
(when (fboundp 'indent-tabs-mode)
(indent-tabs-mode -1)
;; FIXME: Emacs 26
;; compatibility.
(setq-local indent-tabs-mode nil))
(insert replacement)
(indent-rigidly
1 (point) ind)
(setq replacement (buffer-string))))
(goto-char match-start)
(let ((rend (save-excursion
(goto-char end)
(line-end-position))))
(if (string-equal replacement
(buffer-substring match-start rend))
(goto-char rend)
(delete-region match-start
(save-excursion
(goto-char end)
(line-end-position)))
(insert replacement))))))
(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 nil)))))))
(insert replacement))
;; Replacement is the same as the source
;; block. Continue onwards.
(t (goto-char end))))))
((or `babel-call `inline-babel-call)
(org-babel-exp-do-export
(or (org-babel-lob-get-info element)
(user-error "Unknown Babel reference: %s"
(org-element-property :call 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.
(cond
((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)))))
((not rep)
;; Replacement code cannot be determined.
;; Leave the code block as is.
(goto-char end))
(t
;; 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-current-text-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 element))))
(cond ((not replacement) (goto-char end))
((equal replacement "")
(goto-char end)
(skip-chars-forward " \r\t\n")
(forward-line 0)
(delete-region begin (point)))
(t
(if (org-src-preserve-indentation-p element)
;; Indent only code block
;; markers.
(with-temp-buffer
;; Do not use tabs for block
;; indentation.
(when (fboundp 'indent-tabs-mode)
(indent-tabs-mode -1)
;; FIXME: Emacs 26
;; compatibility.
(setq-local indent-tabs-mode nil))
(insert replacement)
(skip-chars-backward " \r\t\n")
(indent-line-to ind)
(goto-char 1)
(indent-line-to ind)
(setq replacement (buffer-string)))
;; Indent everything.
(with-temp-buffer
;; Do not use tabs for block
;; indentation.
(when (fboundp 'indent-tabs-mode)
(indent-tabs-mode -1)
;; FIXME: Emacs 26
;; compatibility.
(setq-local indent-tabs-mode nil))
(insert replacement)
(indent-rigidly
1 (point) ind)
(setq replacement (buffer-string))))
(goto-char match-start)
(let ((rend (save-excursion
(goto-char end)
(line-end-position))))
(if (string-equal replacement
(buffer-substring match-start rend))
(goto-char rend)
(delete-region match-start
(save-excursion
(goto-char end)
(line-end-position)))
(insert replacement))))))
(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 nil))))))
(defun org-babel-exp-do-export (info type &optional hash)
"Return a string with the exported content of a code block.
"Return a string with the exported content of a code block defined by INFO.
TYPE is the code block type: `block', `inline', or `lob'. HASH is the
result hash.
Return nil when exported content cannot be determined.
The function respects the value of the :exports header argument."
(let ((silently (lambda () (let ((session (cdr (assq :session (nth 2 info)))))
(unless (equal "none" session)
(org-babel-exp-results info type 'silent)))))
(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)))))
(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)))))
(org-babel-exp-code info type))
(unknown-value
(warn "Unknown value of src block parameter :exports %S" unknown-value)
nil))))
(defcustom org-babel-exp-code-template
"#+begin_src %lang%switches%flags\n%body\n#+end_src"
"#+begin_src %lang%switches%header-args\n%body\n#+end_src"
"Template used to export the body of code blocks.
This template may be customized to include additional information
such as the code block name, or the values of particular header
@ -361,17 +381,17 @@ and the following %keys may be used.
name ------ the name of the code block
body ------ the body of the code block
switches -- the switches associated to the code block
flags ----- the flags passed to the code block
header-args the header arguments of the code block
In addition to the keys mentioned above, every header argument
defined for the code block may be used as a key and will be
replaced with its value."
:group 'org-babel
:type 'string
:package-version '(Org . "9.6"))
:package-version '(Org . "9.7"))
(defcustom org-babel-exp-inline-code-template
"src_%lang[%switches%flags]{%body}"
"src_%lang[%switches%header-args]{%body}"
"Template used to export the body of inline code blocks.
This template may be customized to include additional information
such as the code block name, or the values of particular header
@ -382,18 +402,17 @@ and the following %keys may be used.
name ------ the name of the code block
body ------ the body of the code block
switches -- the switches associated to the code block
flags ----- the flags passed to the code block
header-args the header arguments of the code block
In addition to the keys mentioned above, every header argument
defined for the code block may be used as a key and will be
replaced with its value."
:group 'org-babel
:type 'string
:version "26.1"
:package-version '(Org . "8.3"))
:package-version '(Org . "9.7"))
(defun org-babel-exp-code (info type)
"Return the original code block formatted for export."
"Return the original code block of TYPE defined by INFO, formatted for export."
(setf (nth 1 info)
(if (string= "strip-export" (cdr (assq :noweb (nth 2 info))))
(replace-regexp-in-string
@ -415,6 +434,11 @@ replaced with its value."
(and (org-string-nw-p f) (concat " " f))))
("flags" . ,(let ((f (assq :flags (nth 2 info))))
(and f (concat " " (cdr f)))))
("header-args"
.
,(org-babel-exp--at-source
(when-let ((params (org-element-property :parameters (org-element-context))))
(concat " " params))))
,@(mapcar (lambda (pair)
(cons (substring (symbol-name (car pair)) 1)
(format "%S" (cdr pair))))
@ -423,6 +447,9 @@ 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.
INFO is as returned by `org-babel-get-src-block-info'. TYPE is the
code block type. HASH is the result hash.
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
@ -436,7 +463,8 @@ inhibit insertion of results into the buffer."
(info (copy-sequence info))
(org-babel-current-src-block-location (point-marker)))
;; Skip code blocks which we can't evaluate.
(when (fboundp (intern (concat "org-babel-execute:" lang)))
(if (not (fboundp (intern (concat "org-babel-execute:" lang))))
(warn "org-export: No org-babel-execute function for %s. Not updating exported results." lang)
(org-babel-eval-wipe-error-buffer)
(setf (nth 1 info) body)
(setf (nth 2 info)

5
lisp/org/ob-forth.el
View file

@ -45,7 +45,7 @@
"Default header arguments for forth code blocks.")
(defun org-babel-execute:forth (body params)
"Execute a block of Forth code with org-babel.
"Execute Forth BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(if (string= "none" (cdr (assq :session params)))
(error "Non-session evaluation not supported for Forth code blocks")
@ -55,7 +55,8 @@ This function is called by `org-babel-execute-src-block'."
(car (last all-results))))))
(defun org-babel-forth-session-execute (body params)
(require 'forth-mode)
"Execute Forth BODY in session defined via PARAMS."
(org-require-package 'forth-mode)
(let ((proc (forth-proc))
(rx " \\(\n:\\|compiled\n\\|ok\n\\)")
(result-start))

34
lisp/org/ob-fortran.el
View file

@ -51,7 +51,8 @@
:type 'string)
(defun org-babel-execute:fortran (body params)
"This function should only be called by `org-babel-execute:fortran'."
"Execute Fortran BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(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 (assq :cmdline params)))
@ -82,9 +83,10 @@
(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."
"Expand a fortran BODY according to its header arguments defined in PARAMS."
(let ((vars (org-babel--get-vars params))
(prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue 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))))
@ -107,12 +109,20 @@ its header arguments."
(concat
;; variables
(mapconcat 'org-babel-fortran-var-to-fortran vars "\n")
body)
(and prologue (concat prologue "\n"))
body
(and prologue (concat prologue "\n")))
params)
body) "\n") "\n")))
(concat
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n"))))
"\n")
"\n")))
(defun org-babel-fortran-ensure-main-wrap (body params)
"Wrap body in a \"program ... end program\" block if none exists."
"Wrap BODY in a \"program ... end program\" block if none exists.
Variable assignments are derived from PARAMS."
(if (string-match "^[ \t]*program\\>" (capitalize body))
(let ((vars (org-babel--get-vars params)))
(when vars (error "Cannot use :vars if `program' statement is present"))
@ -120,20 +130,22 @@ its header arguments."
(format "program main\n%s\nend program main\n" body)))
(defun org-babel-prep-session:fortran (_session _params)
"This function does nothing as fortran is a compiled language with no
"Do nothing.
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)
"This function does nothing as fortran is a compiled language with no
"Do nothing.
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"))
;; helper functions
(defun org-babel-fortran-var-to-fortran (pair)
"Convert an elisp val into a string of fortran code specifying a var
of the same value."
"Convert PAIR of (VAR . VAL) into a string of fortran code.
The fortran code will assign VAL to VAR variable."
;; TODO list support
(let ((var (car pair))
(val (cdr pair)))
@ -164,7 +176,7 @@ of the same value."
(error "The type of parameter %s is not supported by ob-fortran" var)))))
(defun org-babel-fortran-transform-list (val)
"Return a fortran representation of enclose syntactic lists."
"Return a fortran representation of enclose syntactic list VAL."
(if (listp val)
(concat "(/" (mapconcat #'org-babel-fortran-transform-list val ", ") "/)")
(format "%S" val)))

35
lisp/org/ob-gnuplot.el
View file

@ -3,7 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Maintainer: Ihor Radchenko <yantar92@gmail.com>
;; Maintainer: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: literate programming, reproducible research
;; URL: https://orgmode.org
@ -45,6 +45,7 @@
(require 'ob)
(require 'org-macs)
(require 'ox-ascii)
(declare-function org-time-string-to-time "org" (s))
(declare-function orgtbl-to-generic "org-table" (table params))
@ -186,7 +187,7 @@ code."
;; value of the variable
(mapc (lambda (pair)
(setq body (replace-regexp-in-string
(format "\\$%s" (car pair)) (cdr pair) body)))
(format "\\$%s" (car pair)) (cdr pair) body t t)))
vars)
(when prologue (funcall add-to-body prologue))
(when epilogue (setq body (concat body "\n" epilogue)))
@ -196,9 +197,9 @@ code."
body))
(defun org-babel-execute:gnuplot (body params)
"Execute a block of Gnuplot code.
"Execute Gnuplot BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(require 'gnuplot)
(org-require-package 'gnuplot)
(let ((session (cdr (assq :session params)))
(result-type (cdr (assq :results params)))
(body (org-babel-expand-body:gnuplot body params))
@ -251,7 +252,8 @@ This function is called by `org-babel-execute-src-block'."
buffer)))
(defun org-babel-variable-assignments:gnuplot (params)
"Return list of gnuplot statements assigning the block's variables."
"Return list of gnuplot statements assigning the block's variables.
PARAMS is src block parameters alist defining variable assignments."
(mapcar
(lambda (pair) (format "%s = \"%s\"" (car pair) (cdr pair)))
(org-babel-gnuplot-process-vars params)))
@ -262,7 +264,7 @@ This function is called by `org-babel-execute-src-block'."
If there is not a current inferior-process-buffer in SESSION
then create one. Return the initialized session. The current
`gnuplot-mode' doesn't provide support for multiple sessions."
(require 'gnuplot)
(org-require-package 'gnuplot)
(unless (string= session "none")
(save-window-excursion
(gnuplot-send-string-to-gnuplot "" "line")
@ -295,14 +297,29 @@ Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE."
(require 'ox-org)
(with-temp-file data-file
(insert (let ((org-babel-gnuplot-timestamp-fmt
(or (plist-get params :timefmt) "%Y-%m-%d-%H:%M:%S")))
(or (plist-get params :timefmt) "%Y-%m-%d-%H:%M:%S"))
;; Create custom limited backend that will disable
;; advanced ASCII export features that may alter the
;; original data.
(ob-gnuplot-data
(org-export-create-backend
:parent 'ascii
:transcoders
`(;; Do not try to resolve links. Export them verbatim.
(link . (lambda (link _ _) (org-element-interpret-data link)))
;; Drop emphasis markers from verbatim and code.
;; This way, data can use verbatim when escaping
;; is necessary and yet be readable by Gnuplot,
;; which is not aware about Org's markup.
(verbatim . (lambda (verbatim _ _) (org-element-property :value verbatim)))
(code . (lambda (code _ _) (org-element-property :value code)))))))
(orgtbl-to-generic
table
(org-combine-plists
'( :sep "\t" :fmt org-babel-gnuplot-quote-tsv-field
`( :sep "\t" :fmt org-babel-gnuplot-quote-tsv-field
;; Two setting below are needed to make :fmt work.
:raw t
:backend ascii)
:backend ,ob-gnuplot-data)
params)))))
data-file)

8
lisp/org/ob-groovy.el
View file

@ -50,7 +50,7 @@ parameters may be used, like groovy -v"
:type 'string)
(defun org-babel-execute:groovy (body params)
"Execute a block of Groovy code with org-babel.
"Execute Groovy BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(message "Executing Groovy source code block")
(let* ((processed-params (org-babel-process-params params))
@ -81,6 +81,7 @@ println(new Runner().run())
(defun org-babel-groovy-evaluate
(session body &optional result-type result-params)
"Evaluate BODY in external Groovy process.
SESSION must be nil as sessions are not yet supported.
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."
@ -107,9 +108,8 @@ in BODY as elisp."
(error "Sessions are not (yet) supported for Groovy"))
(defun org-babel-groovy-initiate-session (&optional _session)
"If there is not a current inferior-process-buffer in SESSION
then create. Return the initialized session. Sessions are not
supported in Groovy."
"Do nothing.
Sessions are not supported in Groovy."
nil)
(provide 'ob-groovy)

224
lisp/org/ob-haskell.el
View file

@ -61,7 +61,7 @@
(defvar org-babel-haskell-lhs2tex-command "lhs2tex")
(defvar org-babel-haskell-eoe "\"org-babel-haskell-eoe\"")
(defvar org-babel-haskell-eoe "org-babel-haskell-eoe")
(defvar haskell-prompt-regexp)
@ -77,8 +77,35 @@ a parameter, such as \"ghc -v\"."
(defconst org-babel-header-args:haskell '((compile . :any))
"Haskell-specific header arguments.")
(defun org-babel-haskell-with-session--worker (params todo)
"See `org-babel-haskell-with-session'."
(let* ((sn (cdr (assq :session params)))
(session (org-babel-haskell-initiate-session sn params))
(one-shot (equal sn "none")))
(unwind-protect
(funcall todo session)
(when (and one-shot (buffer-live-p session))
;; As we don't control how the session temporary buffer is
;; created, we need to explicitly work around the hooks and
;; query functions.
(with-current-buffer session
(let ((kill-buffer-query-functions nil)
(kill-buffer-hook nil))
(kill-buffer session)))))))
(defmacro org-babel-haskell-with-session (session-symbol params &rest body)
"Get the session identified by PARAMS and run BODY with it.
Get or create a session, as needed to match PARAMS. Assign the session to
SESSION-SYMBOL. Execute BODY. Destroy the session if needed.
Return the value of the last form of BODY."
(declare (indent 2) (debug (symbolp form body)))
`(org-babel-haskell-with-session--worker ,params (lambda (,session-symbol) ,@body)))
(defun org-babel-haskell-execute (body params)
"This function should only be called by `org-babel-execute:haskell'."
"Execute Haskell BODY according to PARAMS.
This function should only be called by `org-babel-execute:haskell'."
(let* ((tmp-src-file (org-babel-temp-file "Haskell-src-" ".hs"))
(tmp-bin-file
(org-babel-process-file-name
@ -122,39 +149,63 @@ a parameter, such as \"ghc -v\"."
(cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))))
(defun org-babel-interpret-haskell (body params)
(require 'inf-haskell)
(org-require-package 'inf-haskell "haskell-mode")
(add-hook 'inferior-haskell-hook
(lambda ()
(setq-local comint-prompt-regexp
(concat haskell-prompt-regexp "\\|^λ?> "))))
(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))
(comint-preoutput-filter-functions
(cons 'ansi-color-filter-apply comint-preoutput-filter-functions))
(raw (org-babel-comint-with-output
(session org-babel-haskell-eoe nil 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-strip-quotes
(cdr (member org-babel-haskell-eoe
(reverse (mapcar #'org-trim raw)))))))
(org-babel-reassemble-table
(let ((result
(pcase result-type
(`output (mapconcat #'identity (reverse results) "\n"))
(`value (car results)))))
(org-babel-result-cond (cdr (assq :result-params params))
result (when result (org-babel-script-escape result))))
(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))))))
(setq-local
org-babel-comint-prompt-regexp-old comint-prompt-regexp
comint-prompt-regexp
(concat haskell-prompt-regexp "\\|^λ?> "))))
(org-babel-haskell-with-session session params
(cl-labels
((send-txt-to-ghci (txt)
(insert txt) (comint-send-input nil t))
(send-eoe ()
(send-txt-to-ghci (concat "putStrLn \"" org-babel-haskell-eoe "\"\n")))
(comint-with-output (todo)
(let ((comint-preoutput-filter-functions
(cons 'ansi-color-filter-apply
comint-preoutput-filter-functions)))
(org-babel-comint-with-output
(session org-babel-haskell-eoe nil nil)
(funcall todo)))))
(let* ((result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params
(org-babel-variable-assignments:haskell params)))
(raw (pcase result-type
(`output
(comint-with-output
(lambda () (send-txt-to-ghci (org-trim full-body)) (send-eoe))))
(`value
;; We first compute the value and store it,
;; ignoring any output.
(comint-with-output
(lambda ()
(send-txt-to-ghci "__LAST_VALUE_IMPROBABLE_NAME__=()::()\n")
(send-txt-to-ghci (org-trim full-body))
(send-txt-to-ghci "__LAST_VALUE_IMPROBABLE_NAME__=it\n")
(send-eoe)))
;; We now display and capture the value.
(comint-with-output
(lambda()
(send-txt-to-ghci "__LAST_VALUE_IMPROBABLE_NAME__\n")
(send-eoe))))))
(results (mapcar #'org-strip-quotes
(cdr (member org-babel-haskell-eoe
(reverse (mapcar #'org-trim raw)))))))
(org-babel-reassemble-table
(let ((result
(pcase result-type
(`output (mapconcat #'identity (reverse results) "\n"))
(`value (car results)))))
(org-babel-result-cond (cdr (assq :result-params params))
result (when result (org-babel-script-escape result))))
(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-execute:haskell (body params)
"Execute a block of Haskell code."
@ -163,13 +214,65 @@ a parameter, such as \"ghc -v\"."
(org-babel-interpret-haskell body params)
(org-babel-haskell-execute body params))))
(defun org-babel-haskell-initiate-session (&optional _session _params)
;; Variable defined in inf-haskell (haskell-mode package).
(defvar inferior-haskell-buffer)
(defvar inferior-haskell-root-dir)
(defun org-babel-haskell-initiate-session (&optional session-name _params)
"Initiate a haskell session.
If there is not a current inferior-process-buffer in SESSION
then create one. Return the initialized session."
(require 'inf-haskell)
(or (get-buffer "*haskell*")
(save-window-excursion (run-haskell) (sleep-for 0.25) (current-buffer))))
Return the initialized session, i.e. the buffer for this session.
When SESSION-NAME is nil, use a global session named
\"*ob-haskell*\". When SESSION-NAME is the string \"none\", use
a temporary buffer. Else, (re)use the session named
SESSION-NAME. The buffer name is the session name. See also
`org-babel-haskell-with-session'."
(org-require-package 'inf-haskell "haskell-mode")
(cond
((equal "none" session-name)
;; Temporary buffer name.
(setq session-name (generate-new-buffer-name " *ob-haskell-tmp*")))
((eq nil session-name)
;; The global default session. As haskell-mode is using the buffer
;; named "*haskell*", we stay away from it.
(setq session-name "*ob-haskell*"))
((not (stringp session-name))
(error "session-name must be a string")))
(let ((session (get-buffer session-name)))
;; NOTE: By construction, as SESSION-NAME is a string, session is
;; either nil or a live buffer.
(save-window-excursion
(or (org-babel-comint-buffer-livep session)
(let ((inferior-haskell-buffer session))
;; As inferior-haskell expects the buffer to be named
;; "*haskell*", we temporarily rename it while executing
;; `run-haskell' (unless the user explicitly requested to
;; use the name "*haskell*").
(when (not (equal "*haskell*" session-name))
(when (bufferp session)
(when (bufferp "*haskell*")
(user-error "Conflicting buffer '*haskell*', rename it or kill it"))
(with-current-buffer session (rename-buffer "*haskell*"))))
(unwind-protect
(let ((inferior-haskell-root-dir default-directory))
(run-haskell)
(sleep-for 0.25)
(setq session inferior-haskell-buffer))
(when (and (not (equal "*haskell*" session-name))
(bufferp session))
(with-current-buffer session (rename-buffer session-name))))
;; Disable secondary prompt: If we do not do this,
;; org-comint may treat secondary prompts as a part of
;; output.
(org-babel-comint-input-command
session
":set prompt-cont \"\"")
session)
))
session))
(defun org-babel-load-session:haskell (session body params)
"Load BODY into SESSION."
@ -226,7 +329,7 @@ constructs (header arguments, no-web syntax etc...) are ignored."
(let* ((contents (buffer-string))
(haskell-regexp
(concat "^\\([ \t]*\\)#\\+begin_src[ \t]haskell*\\(.*\\)[\r\n]"
"\\([^\000]*?\\)[\r\n][ \t]*#\\+end_src.*"))
"\\(\\(?:.\\|\n\\)*?\\)[\r\n][ \t]*#\\+end_src.*"))
(base-name (file-name-sans-extension (buffer-file-name)))
(tmp-file (org-babel-temp-file "haskell-"))
(tmp-org-file (concat tmp-file ".org"))
@ -255,26 +358,27 @@ constructs (header arguments, no-web syntax etc...) are ignored."
t t)
(indent-code-rigidly (match-beginning 0) (match-end 0) indentation)))
(save-excursion
;; export to latex w/org and save as .lhs
(require 'ox-latex)
(find-file tmp-org-file)
;; Ensure we do not clutter kill ring with incomplete results.
(let (org-export-copy-to-kill-ring)
(org-export-to-file 'latex tmp-tex-file))
(kill-buffer nil)
(delete-file tmp-org-file)
(find-file tmp-tex-file)
(goto-char (point-min)) (forward-line 2)
(insert "%include polycode.fmt\n")
;; ensure all \begin/end{code} statements start at the first column
(while (re-search-forward "^[ \t]+\\\\begin{code}[^\000]+\\\\end{code}" nil t)
(replace-match (save-match-data (org-remove-indentation (match-string 0)))
t t))
(setq contents (buffer-string))
(save-buffer) (kill-buffer nil))
(delete-file tmp-tex-file)
;; save org exported latex to a .lhs file
(with-temp-file lhs-file (insert contents))
(unwind-protect
(with-temp-buffer
;; Export to latex w/org and save as .lhs
(require 'ox-latex)
(insert-file-contents tmp-org-file)
;; Ensure we do not clutter kill ring with incomplete results.
(let (org-export-copy-to-kill-ring)
(org-export-to-file 'latex tmp-tex-file)))
(delete-file tmp-org-file))
(unwind-protect
(with-temp-buffer
(insert-file-contents tmp-tex-file)
(goto-char (point-min)) (forward-line 2)
(insert "%include polycode.fmt\n")
;; ensure all \begin/end{code} statements start at the first column
(while (re-search-forward "^[ \t]+\\\\begin{code}\\(?:.\\|\n\\)+\\\\end{code}" nil t)
(replace-match (save-match-data (org-remove-indentation (match-string 0)))
t t))
;; save org exported latex to a .lhs file
(write-region nil nil lhs-file))
(delete-file tmp-tex-file)))
(if (not arg)
(find-file lhs-file)
;; process .lhs file with lhs2tex

6
lisp/org/ob-java.el
View file

@ -341,9 +341,13 @@ is simplest to expand the code block from the inside out."
(imports-val (assq :imports params))
(imports (if imports-val
(split-string (org-babel-read (cdr imports-val) nil) " ")
nil)))
nil))
(prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(with-temp-buffer
(when prologue (insert prologue "\n"))
(insert body)
(when epilogue (insert "\n" epilogue))
;; wrap main. If there are methods defined, but no main method
;; and no class, wrap everything in a generic main method.

15
lisp/org/ob-js.el
View file

@ -76,7 +76,7 @@
"Javascript code to print value of body.")
(defun org-babel-execute:js (body params)
"Execute a block of Javascript code with org-babel.
"Execute Javascript BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let* ((org-babel-js-cmd (or (cdr (assq :cmd params)) org-babel-js-cmd))
(session (cdr (assq :session params)))
@ -99,7 +99,7 @@ This function is called by `org-babel-execute-src-block'."
;; Indium Node REPL. Separate case because Indium
;; REPL is not inherited from Comint mode.
((string= session "*JS REPL*")
(require 'indium-repl)
(org-require-package 'indium-repl "indium")
(unless (get-buffer session)
(indium-run-node org-babel-js-cmd))
(indium-eval full-body))
@ -158,7 +158,8 @@ specifying a variable of the same value."
session))
(defun org-babel-variable-assignments:js (params)
"Return list of Javascript statements assigning the block's variables."
"Return list of Javascript statements assigning the block's variables.
The variables are defined in PARAMS."
(mapcar
(lambda (pair) (format "var %s=%s;"
(car pair) (org-babel-js-var-to-js (cdr pair))))
@ -171,7 +172,7 @@ Return the initialized session."
((string= session "none")
(warn "Session evaluation of ob-js is not supported"))
((string= "*skewer-repl*" session)
(require 'skewer-repl)
(org-require-package 'skewer-repl "skewer-mode")
(let ((session-buffer (get-buffer "*skewer-repl*")))
(if (and session-buffer
(org-babel-comint-buffer-livep (get-buffer session-buffer))
@ -183,7 +184,7 @@ Return the initialized session."
(skewer-repl)
session-buffer)))
((string= "*Javascript REPL*" session)
(require 'js-comint)
(org-require-package 'js-comint)
(let ((session-buffer "*Javascript REPL*"))
(if (and (org-babel-comint-buffer-livep (get-buffer session-buffer))
(comint-check-proc session-buffer))
@ -192,7 +193,9 @@ Return the initialized session."
(sit-for .5)
session-buffer)))
((string= "mozrepl" org-babel-js-cmd)
(require 'moz)
;; FIXME: According to https://github.com/bard/mozrepl, this REPL
;; is outdated and does not work for Firefox >54.
(org-require-package 'moz "mozrepl")
(let ((session-buffer (save-window-excursion
(run-mozilla nil)
(rename-buffer session)

35
lisp/org/ob-julia.el
View file

@ -70,12 +70,15 @@
(defvar ess-local-process-name) ; dynamically scoped
(defvar ess-eval-visibly-p) ; dynamically scoped
(defvar ess-local-customize-alist); dynamically scoped
(defun org-babel-edit-prep:julia (info)
(let ((session (cdr (assq :session (nth 2 info)))))
(when (and session
(string-prefix-p "*" session)
(string-suffix-p "*" session))
(org-babel-julia-initiate-session session nil))))
(defvar ess-gen-proc-buffer-name-function) ; defined in ess-inf.el
(defun org-babel-julia-associate-session (session)
"Associate R code buffer with an R session.
Make SESSION be the inferior ESS process associated with the
current code buffer."
(when-let ((process (get-buffer-process session)))
(setq ess-local-process-name (process-name process))
(ess-make-buffer-current))
(setq-local ess-gen-proc-buffer-name-function (lambda (_) session)))
(defun org-babel-expand-body:julia (body params &optional _graphics-file)
"Expand BODY according to PARAMS, return the expanded body."
@ -181,10 +184,13 @@ end"
(defun org-babel-julia-initiate-session (session params)
"If there is not a current julia process then create one."
(unless (string= session "none")
(let ((session (or session "*Julia*"))
(ess-ask-for-ess-directory
(and (bound-and-true-p ess-ask-for-ess-directory)
(not (cdr (assq :dir params))))))
(let* ((session (or session "*Julia*"))
(ess-ask-for-ess-directory
(and (bound-and-true-p ess-ask-for-ess-directory)
(not (cdr (assq :dir params)))))
;; Make ESS name the process buffer as SESSION.
(ess-gen-proc-buffer-name-function
(lambda (_) session)))
(if (org-babel-comint-buffer-livep session)
session
;; FIXME: Depending on `display-buffer-alist', (julia) may end up
@ -196,13 +202,8 @@ end"
(when (get-buffer session)
;; Session buffer exists, but with dead process
(set-buffer session))
(require 'ess) (set-buffer (julia))
(rename-buffer
(if (bufferp session)
(buffer-name session)
(if (stringp session)
session
(buffer-name))))
(org-require-package 'ess "ESS")
(set-buffer (julia))
(current-buffer))))))
(defun org-babel-julia-graphical-output-file (params)

34
lisp/org/ob-latex.el
View file

@ -52,6 +52,7 @@
(defvar org-format-latex-options) ; From org.el
(defvar org-latex-default-packages-alist) ; From org.el
(defvar org-latex-packages-alist) ; From org.el
(defvar org-preview-latex-process-alist) ; From org.el
(defvar org-babel-default-header-args:latex
'((:results . "latex") (:exports . "results"))
@ -128,6 +129,18 @@ exporting the literal LaTeX source."
:group 'org-babel
:type '(repeat (string)))
(defcustom org-babel-latex-process-alist
`(,(cons 'png (alist-get 'dvipng org-preview-latex-process-alist)))
"Definitions of external processes for LaTeX result generation.
See `org-preview-latex-process-alist' for more details.
The following process symbols are recognized:
- `png' :: Process used to produce .png output."
:group 'org-babel
:package-version '(Org . "9.7")
:type '(alist :tag "LaTeX to image backends"
:value-type (plist)))
(defun org-babel-expand-body:latex (body params)
"Expand BODY according to PARAMS, return the expanded body."
(mapc (lambda (pair) ;; replace variables
@ -136,12 +149,18 @@ exporting the literal LaTeX source."
(regexp-quote (format "%S" (car pair)))
(if (stringp (cdr pair))
(cdr pair) (format "%S" (cdr pair)))
body)))
body t t)))
(org-babel--get-vars params))
(org-trim body))
(let ((prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(org-trim
(concat
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n"))))))
(defun org-babel-execute:latex (body params)
"Execute a block of LaTeX code with Babel.
"Execute LaTeX BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(setq body (org-babel-expand-body:latex body params))
(if (cdr (assq :file params))
@ -163,9 +182,10 @@ This function is called by `org-babel-execute-src-block'."
((and (string-suffix-p ".png" out-file) (not imagemagick))
(let ((org-format-latex-header
(concat org-format-latex-header "\n"
(mapconcat #'identity headers "\n"))))
(mapconcat #'identity headers "\n")))
(org-preview-latex-process-alist org-babel-latex-process-alist))
(org-create-formula-image
body out-file org-format-latex-options in-buffer)))
body out-file org-format-latex-options in-buffer 'png)))
((string= "svg" extension)
(with-temp-file tex-file
(insert (concat (funcall org-babel-latex-preamble params)
@ -273,7 +293,9 @@ This function is called by `org-babel-execute-src-block'."
body))
(defun org-babel-latex-convert-pdf (pdffile out-file im-in-options im-out-options)
"Generate a file from a pdf file using imagemagick."
"Generate OUT-FILE from PDFFILE using imagemagick.
IM-IN-OPTIONS are command line options for input file, as a string;
and IM-OUT-OPTIONS are the output file options."
(let ((cmd (concat "convert " im-in-options " " pdffile " "
im-out-options " " out-file)))
(message "Converting pdffile file %s..." cmd)

123
lisp/org/ob-lilypond.el
View file

@ -40,10 +40,8 @@
(declare-function org-fold-show-all "org-fold" (&optional types))
;; FIXME: Doesn't this rather belong in lilypond-mode.el?
(defalias 'lilypond-mode 'LilyPond-mode)
(add-to-list 'org-babel-tangle-lang-exts '("LilyPond" . "ly"))
(add-to-list 'org-src-lang-modes '("lilypond" . "LilyPond"))
(defvar org-babel-default-header-args:lilypond '()
"Default header arguments for lilypond code blocks.
@ -60,23 +58,13 @@ and stored in `org-babel-default-header-args:lilypond'
See `org-babel-lilypond-set-header-args'.")
(defvar org-babel-lilypond-compile-post-tangle t
"Following the org-babel-tangle (C-c C-v t) command,
org-babel-lilypond-compile-post-tangle determines whether ob-lilypond should
automatically attempt to compile the resultant tangled file.
If the value is nil, no automated compilation takes place.
Default value is t.")
"When non-nil, compile tangled file after `org-babel-tangle'.")
(defvar org-babel-lilypond-display-pdf-post-tangle t
"Following a successful LilyPond compilation
org-babel-lilypond-display-pdf-post-tangle determines whether to automate the
drawing / redrawing of the resultant pdf. If the value is nil,
the pdf is not automatically redrawn. Default value is t.")
"When non-nil, display pdf after successful LilyPond compilation.")
(defvar org-babel-lilypond-play-midi-post-tangle t
"Following a successful LilyPond compilation
org-babel-lilypond-play-midi-post-tangle determines whether to automate the
playing of the resultant midi file. If the value is nil,
the midi file is not automatically played. Default value is t")
"When non-nil, play midi file after successful LilyPond compilation.")
(defvar org-babel-lilypond-ly-command ""
"Command to execute lilypond on your system.
@ -143,7 +131,9 @@ blocks.")
(defun org-babel-expand-body:lilypond (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (org-babel--get-vars params)))
(let ((vars (org-babel--get-vars params))
(prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
@ -152,54 +142,75 @@ blocks.")
(replace-regexp-in-string
(concat "$" (regexp-quote name))
(if (stringp value) value (format "%S" value))
body))))
body t t))))
vars)
body))
(concat
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n")))))
(defun org-babel-execute:lilypond (body params)
"This function is called by `org-babel-execute-src-block'.
Depending on whether we are in arrange mode either:
1. Attempt to execute lilypond block according to header settings
(This is the default basic mode)
2. Tangle all lilypond blocks and process the result (arrange mode)"
"Execute LilyPond src block according to arrange mode.
See `org-babel-execute-src-block' for BODY and PARAMS.
When in arrange mode, tangle all blocks and process the result.
Otherwise, execute block according to header settings."
(org-babel-lilypond-set-header-args org-babel-lilypond-arrange-mode)
(if org-babel-lilypond-arrange-mode
(org-babel-lilypond-tangle)
(org-babel-lilypond-process-basic body params)))
(defun org-babel-lilypond-tangle ()
"ob-lilypond specific tangle, attempts to invoke
=ly-execute-tangled-ly= if tangle is successful. Also passes
specific arguments to =org-babel-tangle=."
"Tangle lilypond blocks, then `org-babel-liypond-execute-tangled-ly'."
(interactive)
(if (org-babel-tangle nil "yes" "lilypond")
(org-babel-lilypond-execute-tangled-ly) nil))
;; https://lilypond.org/doc/v2.24/Documentation/usage/other-programs
(defvar org-babel-lilypond-paper-settings
"#(if (ly:get-option 'use-paper-size-for-page)
(begin (ly:set-option 'use-paper-size-for-page #f)
(ly:set-option 'tall-page-formats '%s)))
\\paper {
indent=0\\mm
tagline=\"\"
oddFooterMarkup=##f
oddHeaderMarkup=##f
bookTitleMarkup=##f
scoreTitleMarkup=##f
}\n"
"The paper settings required to generate music fragments.
They are needed for mixing music and text in basic-mode.")
(defun org-babel-lilypond-process-basic (body params)
"Execute a lilypond block in basic mode."
"Execute a lilypond block in basic mode.
See `org-babel-execute-src-block' for BODY and PARAMS."
(let* ((out-file (cdr (assq :file params)))
(file-type (file-name-extension out-file))
(cmdline (or (cdr (assq :cmdline params))
""))
(in-file (org-babel-temp-file "lilypond-")))
(with-temp-file in-file
(insert (org-babel-expand-body:generic body params)))
(insert
(format org-babel-lilypond-paper-settings file-type)
(org-babel-expand-body:generic body params)))
(org-babel-eval
(concat
org-babel-lilypond-ly-command
" -dbackend=eps "
"-dno-gs-load-fonts "
"-dinclude-eps-fonts "
(or (cdr (assoc (file-name-extension out-file)
'(("pdf" . "--pdf ")
("ps" . "--ps ")
("png" . "--png "))))
(or (assoc-default file-type
'(("pdf" . "--pdf ")
("eps" . "--eps ")))
"--png ")
"--output="
(file-name-sans-extension out-file)
" "
cmdline
in-file) "")) nil)
in-file)
""))
nil)
(defun org-babel-prep-session:lilypond (_session _params)
"Return an error because LilyPond exporter does not support sessions."
@ -219,7 +230,7 @@ If error in compilation, attempt to mark the error in lilypond org file."
(delete-file org-babel-lilypond-temp-file))
(rename-file org-babel-lilypond-tangled-file
org-babel-lilypond-temp-file))
(org-switch-to-buffer-other-window "*lilypond*")
(switch-to-buffer-other-window "*lilypond*")
(erase-buffer)
(org-babel-lilypond-compile-lilyfile org-babel-lilypond-temp-file)
(goto-char (point-min))
@ -229,27 +240,20 @@ If error in compilation, attempt to mark the error in lilypond org file."
(org-babel-lilypond-attempt-to-open-pdf org-babel-lilypond-temp-file)
(org-babel-lilypond-attempt-to-play-midi org-babel-lilypond-temp-file)))))
(defun org-babel-lilypond-compile-lilyfile (file-name &optional test)
"Compile lilypond file and check for compile errors.
FILE-NAME is full path to lilypond (.ly) file."
(message "Compiling LilyPond...")
(let ((arg-1 org-babel-lilypond-ly-command) ;program
;; (arg-2 nil) ;infile
(arg-3 "*lilypond*") ;buffer
(arg-4 t) ;display
(arg-5 (if org-babel-lilypond-gen-png "--png" "")) ;&rest...
(arg-6 (if org-babel-lilypond-gen-html "--html" ""))
(arg-7 (if org-babel-lilypond-gen-pdf "--pdf" ""))
(arg-8 (if org-babel-lilypond-use-eps "-dbackend=eps" ""))
(arg-9 (if org-babel-lilypond-gen-svg "-dbackend=svg" ""))
(arg-10 (concat "--output=" (file-name-sans-extension file-name)))
(arg-11 file-name))
(if test
`(,arg-1 ,nil ,arg-3 ,arg-4 ,arg-5 ,arg-6 ;; arg-2
,arg-7 ,arg-8 ,arg-9 ,arg-10 ,arg-11)
(call-process
arg-1 nil arg-3 arg-4 arg-5 arg-6 ;; arg-2
arg-7 arg-8 arg-9 arg-10 arg-11))))
;;Ignoring second arg for pre Org 9.7 compatibility
(defun org-babel-lilypond-compile-lilyfile (filename &optional _)
"Compile Lilypond FILENAME and check for compile errors."
(message "Compiling %s..." filename)
(let ((args (delq nil (list
(and org-babel-lilypond-gen-png "--png")
(and org-babel-lilypond-gen-html "--html")
(and org-babel-lilypond-gen-pdf "--pdf")
(and org-babel-lilypond-use-eps "-dbackend=eps")
(and org-babel-lilypond-gen-svg "-dbackend=svg")
(concat "--output=" (file-name-sans-extension filename))
filename))))
(apply #'call-process org-babel-lilypond-ly-command nil
"*lilypond*" 'display args)))
(defun org-babel-lilypond-check-for-compile-error (file-name &optional test)
"Check for compile error.
@ -276,7 +280,7 @@ FILE-NAME is full path to lilypond file."
"Mark the erroneous lines in the lilypond org buffer.
FILE-NAME is full path to lilypond file.
LINE is the erroneous line."
(org-switch-to-buffer-other-window
(switch-to-buffer-other-window
(concat (file-name-nondirectory
(org-babel-lilypond-switch-extension file-name ".org"))))
(let ((temp (point)))
@ -290,7 +294,7 @@ LINE is the erroneous line."
(goto-char temp))))
(defun org-babel-lilypond-parse-line-num (&optional buffer)
"Extract error line number."
"Extract error line number in BUFFER or `current-buffer'."
(when buffer (set-buffer buffer))
(let ((start
(and (search-backward ":" nil t)
@ -423,8 +427,7 @@ These depend upon whether we are in Arrange mode i.e. MODE is t."
ob-lilypond-header-args)))
(defun org-babel-lilypond-set-header-args (mode)
"Set org-babel-default-header-args:lilypond
dependent on ORG-BABEL-LILYPOND-ARRANGE-MODE."
"Set lilypond babel header according to MODE."
(setq org-babel-default-header-args:lilypond
(org-babel-lilypond-get-header-args mode)))

70
lisp/org/ob-lisp.el
View file

@ -74,13 +74,19 @@ current directory string."
(let* ((vars (org-babel--get-vars params))
(result-params (cdr (assq :result-params params)))
(print-level nil) (print-length nil)
(prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params)))
(body (if (null vars) (org-trim body)
(concat "(let ("
(mapconcat
(lambda (var)
(format "(%S (quote %S))" (car var) (cdr var)))
vars "\n ")
")\n" body ")"))))
")\n"
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n"))
")"))))
(if (or (member "code" result-params)
(member "pp" result-params))
(format "(pprint %s)" body)
@ -90,37 +96,41 @@ current directory string."
"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 (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))
(org-strip-quotes result)
(condition-case nil
(read (org-babel-lisp-vector-to-list result))
(error 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)))))
(let (eval-and-grab-output)
(pcase org-babel-lisp-eval-fn
(`slime-eval (org-require-package 'slime "SLIME")
(setq eval-and-grab-output 'swank:eval-and-grab-output))
(`sly-eval (org-require-package 'sly "SLY")
(setq eval-and-grab-output 'slynk:eval-and-grab-output)))
(org-babel-reassemble-table
(let ((result
(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
`(,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))
(org-strip-quotes result)
(condition-case nil
(read (org-babel-lisp-vector-to-list result))
(error 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-lisp-vector-to-list (results)
"Convert #(...) values in RESULTS string into a (...) list."
;; TODO: better would be to replace #(...) with [...]
(replace-regexp-in-string "#(" "(" results))

4
lisp/org/ob-lob.el
View file

@ -34,8 +34,8 @@
(declare-function org-babel-ref-split-args "ob-ref" (arg-string))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(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-element-property "org-element-ast" (property node))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(defvar org-babel-library-of-babel nil
"Library of source-code blocks.

98
lisp/org/ob-lua.el
View file

@ -81,8 +81,14 @@ This will typically be `lua-mode'."
:package-version '(Org . "8.3")
:type 'symbol)
(defcustom org-babel-lua-multiple-values-separator ", "
"Separate multiple values with this string."
:group 'org-babel
:package-version '(Org . "9.7")
:type 'string)
(defun org-babel-execute:lua (body params)
"Execute a block of Lua code with Babel.
"Execute Lua BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-lua-initiate-session
(cdr (assq :session params))))
@ -129,7 +135,8 @@ VARS contains resolved variable references."
;; helper functions
(defun org-babel-variable-assignments:lua (params)
"Return a list of Lua statements assigning the block's variables."
"Return a list of Lua statements assigning the block's variables.
The variable definitions are defining in PARAMS."
(mapcar
(lambda (pair)
(format "%s=%s"
@ -176,13 +183,20 @@ Emacs-lisp table, otherwise return the results as a string."
(cdr (assoc session org-babel-lua-buffers)))
(defun org-babel-lua-with-earmuffs (session)
"Return buffer name for SESSION, as *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-session-buffer:lua (session &optional _)
"Return session buffer name for SESSION."
(or (org-babel-lua-session-buffer session)
(org-babel-lua-with-earmuffs session)))
(defun org-babel-lua-without-earmuffs (session)
"Remove stars around *SESSION*, leaving SESSION."
(let ((name (if (stringp session) session (format "%s" session))))
(if (and (string= "*" (substring name 0 1))
(string= "*" (substring name (- (length name) 1))))
@ -243,45 +257,55 @@ 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)
function dump(it, indent)
if indent == nil then
indent = \"\"
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\"
if type(it) == 'table' and %s then
local count = 0
for _ in pairs(it) do
count = count + 1
end
local result = ''
if #indent ~= 0 then
result = result .. '\\n'
end
for key, value in pairs(it) do
result = result
.. indent
.. dump(key)
.. ' = '
.. dump(value, indent .. ' ')
count = count - 1
if count ~= 0 then
result = result .. '\\n'
end
end
return ts
return result
else
return tostring(t)
return tostring(it)
end
end
function main()
%s
function combine(...)
local result = {}
for index = 1, select('#', ...) do
result[index] = dump(select(index, ...))
end
return table.concat(result, '%s')
end
fd=io.open(\"%s\", \"w\")
fd:write(t2s(main()))
fd:close()")
output = io.open('%s', 'w')
output:write(combine(main()))
output:close()")
(defun org-babel-lua-evaluate
(session body &optional result-type result-params preamble)
"Evaluate BODY as Lua code."
"Evaluate BODY in SESSION as Lua code.
RESULT-TYPE and RESULT-PARAMS are passed to
`org-babel-lua-evaluate-session' or
`org-babel-lua-evaluate-external-process'.
PREAMBLE is passed to `org-babel-lua-evaluate-external-process'."
(if session
(org-babel-lua-evaluate-session
session body result-type result-params)
@ -290,10 +314,12 @@ fd:close()")
(defun org-babel-lua-evaluate-external-process
(body &optional result-type result-params preamble)
"Evaluate BODY in external lua process.
"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."
last statement in BODY, as elisp.
RESULT-PARAMS list all the :result header arg parameters.
PREAMBLE string is appended to BODY."
(let ((raw
(pcase result-type
(`output (org-babel-eval org-babel-lua-command
@ -305,15 +331,17 @@ last statement in BODY, as elisp."
(concat
preamble (and preamble "\n")
(format
(if (member "pp" result-params)
org-babel-lua-pp-wrapper-method
org-babel-lua-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")
"[\r\n]")
"\n")
(if (member "pp" result-params)
"true" "false")
org-babel-lua-multiple-values-separator
(org-babel-process-file-name tmp-file 'noquote))))
(org-babel-eval-read-file tmp-file))))))
(org-babel-result-cond result-params
@ -399,7 +427,7 @@ fd:close()"
(org-babel-lua-table-or-string results)))))
(defun org-babel-lua-read-string (string)
"Strip single quotes from around Lua string."
"Strip single quotes from around Lua STRING."
(org-unbracket-string "'" "'" string))
(provide 'ob-lua)

3
lisp/org/ob-makefile.el
View file

@ -36,7 +36,8 @@
(defvar org-babel-default-header-args:makefile '())
(defun org-babel-execute:makefile (body _params)
"Execute a block of makefile code.
"Execute makefile BODY.
Second function argument is ignored.
This function is called by `org-babel-execute-src-block'."
body)

123
lisp/org/ob-maxima.el
View file

@ -37,6 +37,11 @@
(require 'ob)
(defconst org-babel-header-args:maxima
'((batch . ((batchload batch load)))
(graphics-pkg . ((plot draw))))
"Maxima-specific header arguments.")
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("maxima" . "max"))
@ -48,43 +53,102 @@
:group 'org-babel
:type 'string)
(defvar org-babel-maxima--command-arguments-default
"--very-quiet"
"Command-line arguments sent to Maxima by default.
If the `:batch' header argument is set to `batchload' or unset,
then the `:cmdline' header argument is appended to this default;
otherwise, if the `:cmdline' argument is set, it over-rides this
default. See `org-babel-maxima-command' and
`org-babel-execute:maxima'.")
(defvar org-babel-maxima--graphic-package-options
'((plot . "(set_plot_option ('[gnuplot_term, %s]), set_plot_option ('[gnuplot_out_file, %S]))$")
(draw . "(load(draw), set_draw_defaults(terminal='%s,file_name=%S))$"))
"An alist of graphics packages and Maxima code.
Each element is a cons (PACKAGE-NAME . FORMAT-STRING).
FORMAT-STRING contains Maxima code to configure the graphics
package; it must contain `%s' to set the terminal and `%S' to set
the filename, in that order. The default graphics package is
`plot'; `draw' is also supported. See
`org-babel-maxima-expand'.")
(defvar org-babel-maxima--default-epilogue
'((graphical-output . "gnuplot_close ()$")
(non-graphical-output . ""))
"The final Maxima code executed in a source block.
An alist with the epilogue for graphical and non-graphical
output. See `org-babel-maxima-expand'.")
(defun org-babel-maxima-expand (body params)
"Expand a block of Maxima code according to its header arguments."
(let ((vars (org-babel--get-vars params))
(epilogue (cdr (assq :epilogue params)))
(prologue (cdr (assq :prologue params))))
"Expand Maxima BODY according to its header arguments from PARAMS."
(let* ((vars (org-babel--get-vars params))
(graphic-file (ignore-errors (org-babel-graphical-output-file params)))
(epilogue (cdr (assq :epilogue params)))
(prologue (cdr (assq :prologue params))))
(mapconcat 'identity
(list
;; Any code from the specified prologue at the start.
prologue
;; graphic output
(let ((graphic-file (ignore-errors (org-babel-graphical-output-file params))))
(if graphic-file
(format
"set_plot_option ([gnuplot_term, png]); set_plot_option ([gnuplot_out_file, %S]);"
graphic-file)
""))
;; variables
(mapconcat 'org-babel-maxima-var-to-maxima vars "\n")
;; body
body
;; Any code from the specified epilogue at the end.
epilogue
"gnuplot_close ()$")
(delq nil
(list
;; Any code from the specified prologue at the start.
prologue
;; graphic output
(if graphic-file
(let* ((graphics-pkg (intern (or (cdr (assq :graphics-pkg params)) "plot")))
(graphic-format-string (cdr (assq graphics-pkg org-babel-maxima--graphic-package-options)))
(graphic-terminal (file-name-extension graphic-file))
(graphic-file (if (eq graphics-pkg 'plot) graphic-file (file-name-sans-extension graphic-file))))
(format graphic-format-string graphic-terminal graphic-file)))
;; variables
(mapconcat 'org-babel-maxima-var-to-maxima vars "\n")
;; body
body
;; Any code from the specified epilogue at the end.
epilogue
(if graphic-file
(cdr (assq :graphical-output org-babel-maxima--default-epilogue))
(cdr (assq :non-graphical-output org-babel-maxima--default-epilogue)))))
"\n")))
(defvar org-babel-maxima--output-filter-regexps
'("batch" ;; remove the `batch' or `batchload' line
"^rat: replaced .*$" ;; remove notices from `rat'
"^;;; Loading #P" ;; remove notices from the lisp implementation
"^read and interpret" ;; remove notice from `batch'
"^(%\\([i]-?[0-9]+\\))[ ]$" ;; remove empty input lines from `batch'-ing
)
"Regexps to remove extraneous lines from Maxima's output.
See `org-babel-maxima--output-filter'.")
(defun org-babel-maxima--output-filter (line)
"Filter empty or undesired lines from Maxima output.
Return nil if LINE is zero-length or it matches a regexp in
`org-babel-maxima--output-filter'; otherwise, return LINE."
(unless (or (= 0 (length line))
(cl-some #'(lambda(r) (string-match r line))
org-babel-maxima--output-filter-regexps))
line))
(defun org-babel-execute:maxima (body params)
"Execute a block of Maxima entries with org-babel.
"Execute Maxima BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(message "Executing Maxima source code block")
(let ((result-params (split-string (or (cdr (assq :results params)) "")))
(result
(let* ((cmdline (or (cdr (assq :cmdline params)) ""))
(batch/load (or (cdr (assq :batch params)) "batchload"))
(cmdline (if (or (equal cmdline "") (equal batch/load "batchload"))
;; legacy behaviour:
;; ensure that --very-quiet is on command-line by default
(concat cmdline " " org-babel-maxima--command-arguments-default)
;; if using an alternate loader, :cmdline overwrites default
cmdline))
(in-file (org-babel-temp-file "maxima-" ".max"))
(cmd (format "%s --very-quiet -r %s %s"
(cmd (format "%s -r %s %s"
org-babel-maxima-command
(shell-quote-argument
(format "batchload(%S)$" in-file))
;; bind linenum to 0 so the first line
;; of in-file has line number 1
(format "(linenum:0, %s(%S))$" batch/load in-file))
cmdline)))
(with-temp-file in-file (insert (org-babel-maxima-expand body params)))
(message cmd)
@ -93,12 +157,7 @@ This function is called by `org-babel-execute-src-block'."
(mapconcat
#'identity
(delq nil
(mapcar (lambda (line)
(unless (or (string-match "batch" line)
(string-match "^rat: replaced .*$" line)
(string-match "^;;; Loading #P" line)
(= 0 (length line)))
line))
(mapcar #'org-babel-maxima--output-filter
(split-string raw "[\r\n]"))) "\n")))))
(if (ignore-errors (org-babel-graphical-output-file params))
nil
@ -110,11 +169,11 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-prep-session:maxima (_session _params)
"Throw an error. Maxima does not support sessions."
(error "Maxima does not support sessions"))
(defun org-babel-maxima-var-to-maxima (pair)
"Convert an elisp val into a string of maxima code specifying a var
of the same value."
"Convert an elisp variable-value PAIR to maxima code."
(let ((var (car pair))
(val (cdr pair)))
(when (symbolp val)

7
lisp/org/ob-ocaml.el
View file

@ -63,7 +63,7 @@
:type 'string)
(defun org-babel-execute:ocaml (body params)
"Execute a block of Ocaml code with Babel."
"Execute Ocaml BODY according to PARAMS."
(let* ((full-body (org-babel-expand-body:generic
body params
(org-babel-variable-assignments:ocaml params)))
@ -109,7 +109,7 @@
(defvar tuareg-interactive-buffer-name)
(defun org-babel-prep-session:ocaml (session _params)
"Prepare SESSION according to the header arguments in PARAMS."
(require 'tuareg)
(org-require-package 'tuareg)
(let ((tuareg-interactive-buffer-name (if (and (not (string= session "none"))
(not (string= session "default"))
(stringp session))
@ -121,7 +121,8 @@
(get-buffer tuareg-interactive-buffer-name)))
(defun org-babel-variable-assignments:ocaml (params)
"Return list of ocaml statements assigning the block's variables."
"Return list of ocaml statements assigning the block's variables.
The variables are defined in PARAMS."
(mapcar
(lambda (pair) (format "let %s = %s;;" (car pair)
(org-babel-ocaml-elisp-to-ocaml (cdr pair))))

41
lisp/org/ob-octave.el
View file

@ -70,11 +70,12 @@ end")
(defvar org-babel-octave-eoe-output "ans = org_babel_eoe")
(defun org-babel-execute:matlab (body params)
"Execute a block of matlab code with Babel."
"Execute Matlab BODY according to PARAMS."
(org-babel-execute:octave body params 'matlab))
(defun org-babel-execute:octave (body params &optional matlabp)
"Execute a block of octave code with Babel."
"Execute Octave or Matlab BODY according to PARAMS.
When MATLABP is non-nil, execute Matlab. Otherwise, execute Octave."
(let* ((session
(funcall (intern (format "org-babel-%s-initiate-session"
(if matlabp "matlab" "octave")))
@ -109,7 +110,8 @@ end")
(org-babel-prep-session:octave session params 'matlab))
(defun org-babel-variable-assignments:octave (params)
"Return list of octave statements assigning the block's variables."
"Return list of octave statements assigning the block's variables.
The variables are taken from PARAMS."
(mapcar
(lambda (pair)
(format "%s=%s;"
@ -120,21 +122,22 @@ end")
(defalias 'org-babel-variable-assignments:matlab
'org-babel-variable-assignments:octave)
(defun org-babel-octave-var-to-octave (var)
"Convert an emacs-lisp value into an octave variable.
(defun org-babel-octave-var-to-octave (value)
"Convert an emacs-lisp VALUE into an octave variable.
Converts an emacs-lisp variable into a string of octave code
specifying a variable of the same value."
(if (listp var)
(concat "[" (mapconcat #'org-babel-octave-var-to-octave var
(if (listp (car var)) "; " ",")) "]")
(if (listp value)
(concat "[" (mapconcat #'org-babel-octave-var-to-octave value
(if (listp (car value)) "; " ",")) "]")
(cond
((stringp var)
(format "'%s'" var))
((stringp value)
(format "'%s'" value))
(t
(format "%s" var)))))
(format "%s" value)))))
(defun org-babel-prep-session:octave (session params &optional matlabp)
"Prepare SESSION according to the header arguments specified in PARAMS."
"Prepare SESSION according to the header arguments specified in PARAMS.
The session will be an Octave session, unless MATLABP is non-nil."
(let* ((session (org-babel-octave-initiate-session session params matlabp))
(var-lines (org-babel-variable-assignments:octave params)))
(org-babel-comint-in-buffer session
@ -147,15 +150,18 @@ specifying a variable of the same value."
(defun org-babel-matlab-initiate-session (&optional session params)
"Create a matlab inferior process buffer.
If there is not a current inferior-process-buffer in SESSION then
create. Return the initialized session."
create. Return the initialized session. PARAMS are src block parameters."
(org-babel-octave-initiate-session session params 'matlab))
(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."
(if matlabp (require 'matlab) (or (require 'octave-inf nil 'noerror)
(require 'octave)))
create. Return the initialized session. The session will be an
Octave session, unless MATLABP is non-nil."
(if matlabp
(org-require-package 'matlab "matlab-mode")
(or (require 'octave-inf nil 'noerror)
(require 'octave)))
(unless (string= session "none")
(let ((session (or session
(if matlabp "*Inferior Matlab*" "*Inferior Octave*"))))
@ -178,7 +184,8 @@ value of the last statement in BODY, as elisp."
(org-babel-octave-evaluate-external-process body result-type matlabp)))
(defun org-babel-octave-evaluate-external-process (body result-type matlabp)
"Evaluate BODY in an external octave process."
"Evaluate BODY in an external Octave or Matalab process.
Process the result as RESULT-TYPE. Use Octave, unless MATLABP is non-nil."
(let ((cmd (if matlabp
org-babel-matlab-shell-command
org-babel-octave-shell-command)))

16
lisp/org/ob-org.el
View file

@ -45,15 +45,25 @@
"Default header inserted during export of org blocks.")
(defun org-babel-expand-body:org (body params)
"Expand Org BODY according to PARAMS.
$VAR instances are replaced by VAR values defined in PARAMS."
(dolist (var (org-babel--get-vars params))
(setq body (replace-regexp-in-string
(regexp-quote (format "$%s" (car var)))
(format "%s" (cdr var))
body nil 'literal)))
body)
body 'fixedcase 'literal)))
(let ((prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(concat
(and prologue (concat prologue "\n"))
body
(and epilogue (concat "\n" epilogue "\n")))))
(defun org-babel-execute:org (body params)
"Execute a block of Org code with.
"Execute a Org BODY according to PARAMS.
The BODY is returned expanded as is or exported, if PARAMS define
latex/html/ascii result type.
This function is called by `org-babel-execute-src-block'."
(let ((result-params (split-string (or (cdr (assq :results params)) "")))
(body (org-babel-expand-body:org

1
lisp/org/ob-plantuml.el
View file

@ -143,6 +143,7 @@ This function is called by `org-babel-execute-src-block'."
("eps" '("-teps"))
("pdf" '("-tpdf"))
("tex" '("-tlatex"))
("tikz" '("-tlatex:nopreamble"))
("vdx" '("-tvdx"))
("xmi" '("-txmi"))
("scxml" '("-tscxml"))

7
lisp/org/ob-processing.el
View file

@ -78,7 +78,7 @@
(defun org-babel-processing-view-sketch ()
"Show the sketch of the Processing block under point in an external viewer."
(interactive)
(require 'processing-mode)
(org-require-package 'processing-mode)
(let ((info (org-babel-get-src-block-info)))
(if (string= (nth 0 info) "processing")
(let* ((body (nth 1 info))
@ -118,7 +118,7 @@
(message "Not inside a Processing source block."))))
(defun org-babel-execute:processing (body params)
"Execute a block of Processing code.
"Execute Processing code BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let ((sketch-code
(org-babel-expand-body:generic
@ -144,7 +144,8 @@ Processing does not support sessions."
(error "Processing does not support sessions"))
(defun org-babel-variable-assignments:processing (params)
"Return list of processing statements assigning the block's variables."
"Return list of processing statements assigning the block's variables.
The variable assignments are defined in PARAMS."
(mapcar #'org-babel-processing-var-to-processing
(org-babel--get-vars params)))

452
lisp/org/ob-python.el
View file

@ -36,53 +36,70 @@
(require 'org-macs)
(require 'python)
(declare-function py-shell "ext:python-mode" (&rest args))
(declare-function py-choose-shell "ext:python-mode" (&optional shell))
(declare-function py-shell-send-string "ext:python-mode" (strg &optional process))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("python" . "py"))
(defvar org-babel-default-header-args:python '())
(defcustom org-babel-python-command "python"
"Name of the command for executing Python code."
:version "24.4"
:package-version '(Org . "8.0")
(defconst org-babel-header-args:python
'((return . :any)
(python . :any)
(async . ((yes no))))
"Python-specific header arguments.")
(defcustom org-babel-python-command 'auto
"Command (including arguments) for interactive and non-interactive Python code.
When not `auto', it overrides `org-babel-python-command-session'
and `org-babel-python-command-nonsession'."
:package-version '(Org . "9.7")
:group 'org-babel
:type '(choice string (const auto)))
(defcustom org-babel-python-command-session 'auto
"Command (including arguments) for starting interactive Python sessions.
If `auto' (the default), uses the values from
`python-shell-interpreter' and `python-shell-interpreter-args'.
If `org-babel-python-command' is set, then it overrides this
option."
:package-version '(Org . "9.7")
:group 'org-babel
:type '(choice string (const auto)))
(defcustom org-babel-python-command-nonsession "python"
"Command (including arguments) for executing non-interactive Python code.
If `org-babel-python-command' is set, then it overrides this option."
:package-version '(Org . "9.7")
:group 'org-babel
:type 'string)
(defcustom org-babel-python-mode
(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
:version "24.4"
:package-version '(Org . "8.0")
:type 'symbol)
(defcustom org-babel-python-hline-to "None"
"Replace hlines in incoming tables with this when translating to python."
:group 'org-babel
:version "24.4"
:package-version '(Org . "8.0")
:type 'string)
(defcustom org-babel-python-None-to 'hline
"Replace `None' in python tables with this before returning."
:group 'org-babel
:version "24.4"
:package-version '(Org . "8.0")
:type 'symbol)
(defun org-babel-python-associate-session (session)
"Associate Python code buffer with an Python session.
Make SESSION without earmuffs be the Python buffer name."
(setq-local python-shell-buffer-name
(org-babel-python-without-earmuffs session)))
(defun org-babel-execute:python (body params)
"Execute a block of Python code with Babel.
"Execute Python BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let* ((org-babel-python-command
(or (cdr (assq :python params))
org-babel-python-command))
(session (org-babel-python-initiate-session
(cdr (assq :session params))))
(graphics-file (and (member "graphics" (assq :result-params params))
(org-babel-graphical-output-file params)))
(result-params (cdr (assq :result-params params)))
(result-type (cdr (assq :result-type params)))
(return-val (when (eq result-type 'value)
@ -98,7 +115,7 @@ This function is called by `org-babel-execute-src-block'."
(format (if session "\n%s" "\nreturn %s") return-val))))
(result (org-babel-python-evaluate
session full-body result-type
result-params preamble async)))
result-params preamble async graphics-file)))
(org-babel-reassemble-table
result
(org-babel-pick-name (cdr (assq :colname-names params))
@ -130,8 +147,63 @@ VARS contains resolved variable references."
;; helper functions
(defconst org-babel-python--output-graphics-wrapper "\
import matplotlib.pyplot
matplotlib.pyplot.gcf().clear()
%s
matplotlib.pyplot.savefig('%s')"
"Format string for saving Python graphical output.
Has two %s escapes, for the Python code to be evaluated, and the
file to save the graphics to.")
(defconst org-babel-python--def-format-value "\
def __org_babel_python_format_value(result, result_file, result_params):
with open(result_file, 'w') as f:
if 'graphics' in result_params:
result.savefig(result_file)
elif 'pp' in result_params:
import pprint
f.write(pprint.pformat(result))
elif 'list' in result_params and isinstance(result, dict):
f.write(str(['{} :: {}'.format(k, v) for k, v in result.items()]))
else:
if not set(result_params).intersection(\
['scalar', 'verbatim', 'raw']):
def dict2table(res):
if isinstance(res, dict):
return [(k, dict2table(v)) for k, v in res.items()]
elif isinstance(res, list) or isinstance(res, tuple):
return [dict2table(x) for x in res]
else:
return res
if 'table' in result_params:
result = dict2table(result)
try:
import pandas
except ImportError:
pass
else:
if isinstance(result, pandas.DataFrame) and 'table' in result_params:
result = [[result.index.name or ''] + list(result.columns)] + \
[None] + [[i] + list(row) for i, row in result.iterrows()]
elif isinstance(result, pandas.Series) and 'table' in result_params:
result = list(result.items())
try:
import numpy
except ImportError:
pass
else:
if isinstance(result, numpy.ndarray):
if 'table' in result_params:
result = result.tolist()
else:
result = repr(result)
f.write(str(result))"
"Python function to format value result and save it to file.")
(defun org-babel-variable-assignments:python (params)
"Return a list of Python statements assigning the block's variables."
"Return a list of Python statements assigning the block's variables.
The assignments are defined in PARAMS."
(mapcar
(lambda (pair)
(format "%s=%s"
@ -153,9 +225,13 @@ specifying a variable of the same value."
(defun org-babel-python-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 the results look like a list or tuple (but not a dict), then
convert them into an Emacs-lisp table. Otherwise return the
results as a string."
(let ((res (if (and (> (length results) 0)
(string-equal "{" (substring results 0 1)))
results ;don't covert dicts to elisp
(org-babel-script-escape results))))
(if (listp res)
(mapcar (lambda (el) (if (eq el 'None)
org-babel-python-None-to el))
@ -169,6 +245,7 @@ Emacs-lisp table, otherwise return the results as a string."
(cdr (assoc session org-babel-python-buffers)))
(defun org-babel-python-with-earmuffs (session)
"Return SESSION name as string, ensuring *...* around."
(let ((name (if (stringp session) session (format "%s" session))))
(if (and (string= "*" (substring name 0 1))
(string= "*" (substring name (- (length name) 1))))
@ -176,74 +253,113 @@ Emacs-lisp table, otherwise return the results as a string."
(format "*%s*" name))))
(defun org-babel-python-without-earmuffs (session)
"Return SESSION name as string, without *...* around."
(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 py-which-bufname)
(defvar python-shell-buffer-name)
(defun org-babel-session-buffer:python (session &optional _)
"Return session buffer name for SESSION."
(or (org-babel-python-session-buffer session)
(org-babel-python-with-earmuffs session)))
(defun org-babel-python--python-util-comint-end-of-output-p ()
"Return non-nil if the last prompt matches input prompt.
Backport of `python-util-comint-end-of-output-p' to emacs28. To
be removed after minimum supported version reaches emacs29."
(when-let ((prompt (python-util-comint-last-prompt)))
(python-shell-comint-end-of-output-p
(buffer-substring-no-properties
(car prompt) (cdr prompt)))))
(defun org-babel-python--command (is-session)
"Helper function to return the Python command.
This checks `org-babel-python-command', and then
`org-babel-python-command-session' (if IS-SESSION) or
`org-babel-python-command-nonsession' (if not IS-SESSION). If
IS-SESSION, this might return `nil', which means to use
`python-shell-calculate-command'."
(or (unless (eq org-babel-python-command 'auto)
org-babel-python-command)
(if is-session
(unless (eq org-babel-python-command-session 'auto)
org-babel-python-command-session)
org-babel-python-command-nonsession)))
(defvar-local org-babel-python--initialized nil
"Flag used to mark that python session has been initialized.")
(defun org-babel-python--setup-session ()
"Babel Python session setup code, to be run once per session.
Function should be run from within the Python session buffer.
This is often run as a part of `python-shell-first-prompt-hook',
unless the Python session was created outside Org."
(python-shell-send-string-no-output org-babel-python--def-format-value)
(setq-local org-babel-python--initialized t))
(defun org-babel-python-initiate-session-by-key (&optional session)
"Initiate a python session.
If there is not a current inferior-process-buffer in SESSION
then create. Return the initialized session."
If there is not a current inferior-process-buffer matching
SESSION then create it. If inferior process already
exists (e.g. if it was manually started with `run-python'), make
sure it's configured to work with ob-python. If session has
already been configured as such, do nothing. Return the
initialized session."
(save-window-excursion
(let* ((session (if session (intern session) :default))
(py-buffer (org-babel-python-session-buffer session))
(cmd (if (member system-type '(cygwin windows-nt ms-dos))
(concat org-babel-python-command " -i")
org-babel-python-command)))
(cond
((eq 'python org-babel-python-mode) ; python.el
(unless py-buffer
(setq py-buffer (org-babel-python-with-earmuffs session)))
(let ((python-shell-buffer-name
(org-babel-python-without-earmuffs py-buffer)))
(run-python cmd)
(with-current-buffer py-buffer
(add-hook
'python-shell-first-prompt-hook
(lambda ()
(setq-local org-babel-python--initialized t)
(message "I am running!!!"))
nil 'local))))
((and (eq 'python-mode org-babel-python-mode)
(fboundp 'py-shell)) ; python-mode.el
(require 'python-mode)
;; Make sure that py-which-bufname is initialized, as otherwise
;; it will be overwritten the first time a Python buffer is
;; created.
(py-choose-shell)
;; `py-shell' creates a buffer whose name is the value of
;; `py-which-bufname' with '*'s at the beginning and end
(let* ((bufname (if (and py-buffer (buffer-live-p py-buffer))
(replace-regexp-in-string ;; zap surrounding *
"^\\*\\([^*]+\\)\\*$" "\\1" py-buffer)
(concat "Python-" (symbol-name session))))
(py-which-bufname bufname))
(setq py-buffer (org-babel-python-with-earmuffs bufname))
(py-shell nil nil t org-babel-python-command py-buffer nil nil t nil)))
(t
(error "No function available for running an inferior Python")))
;; Wait until Python initializes.
(if (eq 'python org-babel-python-mode) ; python.el
;; This is more reliable compared to
;; `org-babel-comint-wait-for-output' as python may emit
;; multiple prompts during initialization.
(with-current-buffer py-buffer
(while (not org-babel-python--initialized)
(sleep-for 0.01)))
(org-babel-comint-wait-for-output py-buffer))
(py-buffer (org-babel-session-buffer:python session))
(python-shell-buffer-name
(org-babel-python-without-earmuffs py-buffer))
(existing-session-p (comint-check-proc py-buffer))
(cmd (org-babel-python--command t)))
(if cmd
(let* ((cmd-split (split-string-and-unquote cmd))
(python-shell-interpreter (car cmd-split))
(python-shell-interpreter-args
(combine-and-quote-strings
(append (cdr cmd-split)
(when (member system-type
'(cygwin windows-nt ms-dos))
(list "-i"))))))
(run-python))
(run-python))
(with-current-buffer py-buffer
(if existing-session-p
;; Session was created outside Org. Assume first prompt
;; already happened; run session setup code directly
(unless org-babel-python--initialized
;; Ensure first prompt. Based on python-tests.el
;; (`python-tests-shell-wait-for-prompt')
(while (not (org-babel-python--python-util-comint-end-of-output-p))
(sit-for 0.1))
(org-babel-python--setup-session))
;; Adding to `python-shell-first-prompt-hook' immediately
;; after `run-python' should be safe from race conditions,
;; because subprocess output only arrives when Emacs is
;; waiting (see elisp manual, "Output from Processes")
(add-hook
'python-shell-first-prompt-hook
#'org-babel-python--setup-session
nil 'local)))
;; Wait until Python initializes
;; This is more reliable compared to
;; `org-babel-comint-wait-for-output' as python may emit
;; multiple prompts during initialization.
(with-current-buffer py-buffer
(while (not org-babel-python--initialized)
(sleep-for 0.010)))
(setq org-babel-python-buffers
(cons (cons session py-buffer)
(assq-delete-all session org-babel-python-buffers)))
session)))
(defun org-babel-python-initiate-session (&optional session _params)
"Create a session named SESSION according to PARAMS."
"Initiate Python session named SESSION according to PARAMS.
If there is not a current inferior-process-buffer matching
SESSION then create it. If inferior process already
exists (e.g. if it was manually started with `run-python'), make
sure it's configured to work with ob-python. If session has
already been configured as such, do nothing."
(unless (string= session "none")
(org-babel-python-session-buffer
(org-babel-python-initiate-session-by-key session))))
@ -251,31 +367,10 @@ then create. Return the initialized session."
(defvar org-babel-python-eoe-indicator "org_babel_python_eoe"
"A string to indicate that evaluation has completed.")
(defconst org-babel-python-wrapper-method
"
def main():
%s
open('%s', 'w').write( str(main()) )")
(defconst org-babel-python-pp-wrapper-method
"
import pprint
def main():
%s
open('%s', 'w').write( pprint.pformat(main()) )")
(defconst org-babel-python--exec-tmpfile "\
with open('%s') as __org_babel_python_tmpfile:
exec(compile(__org_babel_python_tmpfile.read(), __org_babel_python_tmpfile.name, 'exec'))"
"Template for Python session command with output results.
Has a single %s escape, the tempfile containing the source code
to evaluate.")
(defun org-babel-python-format-session-value
(src-file result-file result-params)
"Return Python code to evaluate SRC-FILE and write result to RESULT-FILE."
"Return Python code to evaluate SRC-FILE and write result to RESULT-FILE.
RESULT-PARAMS defines the result type."
(format "\
import ast
with open('%s') as __org_babel_python_tmpfile:
@ -286,30 +381,25 @@ if isinstance(__org_babel_python_final, ast.Expr):
exec(compile(__org_babel_python_ast, '<string>', 'exec'))
__org_babel_python_final = eval(compile(ast.Expression(
__org_babel_python_final.value), '<string>', 'eval'))
with open('%s', 'w') as __org_babel_python_tmpfile:
if %s:
import pprint
__org_babel_python_tmpfile.write(pprint.pformat(__org_babel_python_final))
else:
__org_babel_python_tmpfile.write(str(__org_babel_python_final))
else:
exec(compile(__org_babel_python_ast, '<string>', 'exec'))
__org_babel_python_final = None"
__org_babel_python_final = None
__org_babel_python_format_value(__org_babel_python_final, '%s', %s)"
(org-babel-process-file-name src-file 'noquote)
(org-babel-process-file-name result-file 'noquote)
(if (member "pp" result-params) "True" "False")))
(org-babel-python-var-to-python result-params)))
(defun org-babel-python-evaluate
(session body &optional result-type result-params preamble async)
(session body &optional result-type result-params preamble async graphics-file)
"Evaluate BODY as Python code."
(if session
(if async
(org-babel-python-async-evaluate-session
session body result-type result-params)
session body result-type result-params graphics-file)
(org-babel-python-evaluate-session
session body result-type result-params))
session body result-type result-params graphics-file))
(org-babel-python-evaluate-external-process
body result-type result-params preamble)))
body result-type result-params preamble graphics-file)))
(defun org-babel-python--shift-right (body &optional count)
(with-temp-buffer
@ -325,33 +415,40 @@ else:
(buffer-string)))
(defun org-babel-python-evaluate-external-process
(body &optional result-type result-params preamble)
(body &optional result-type result-params preamble graphics-file)
"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."
string. If RESULT-TYPE equals `value' then return the value of
the last statement in BODY, as elisp. If GRAPHICS-FILE is
non-nil, then save graphical results to that file instead."
(let ((raw
(pcase result-type
(`output (org-babel-eval org-babel-python-command
(`output (org-babel-eval (org-babel-python--command nil)
(concat preamble (and preamble "\n")
body)))
(`value (let ((tmp-file (org-babel-temp-file "python-")))
(org-babel-eval
org-babel-python-command
(if graphics-file
(format org-babel-python--output-graphics-wrapper
body graphics-file)
body))))
(`value (let ((results-file (or graphics-file
(org-babel-temp-file "python-"))))
(org-babel-eval (org-babel-python--command nil)
(concat
preamble (and preamble "\n")
(format
(if (member "pp" result-params)
org-babel-python-pp-wrapper-method
org-babel-python-wrapper-method)
(org-babel-python--shift-right body)
(org-babel-process-file-name tmp-file 'noquote))))
(org-babel-eval-read-file tmp-file))))))
(concat org-babel-python--def-format-value "
def main():
%s
__org_babel_python_format_value(main(), '%s', %s)")
(org-babel-python--shift-right body)
(org-babel-process-file-name results-file 'noquote)
(org-babel-python-var-to-python result-params))))
(org-babel-eval-read-file results-file))))))
(org-babel-result-cond result-params
raw
(org-babel-python-table-or-string (org-trim raw)))))
(org-babel-python-table-or-string raw))))
(defun org-babel-python--send-string (session body)
(defun org-babel-python-send-string (session body)
"Pass BODY to the Python process in SESSION.
Return output."
(with-current-buffer session
@ -369,48 +466,54 @@ finally:
print('%s')"
(org-babel-python--shift-right body 4)
org-babel-python-eoe-indicator)))
(if (not (eq 'python-mode org-babel-python-mode))
(let ((python-shell-buffer-name
(org-babel-python-without-earmuffs session)))
(python-shell-send-string body))
(require 'python-mode)
(py-shell-send-string body (get-buffer-process session)))
(let ((python-shell-buffer-name
(org-babel-python-without-earmuffs session)))
(python-shell-send-string body))
;; same as `python-shell-comint-end-of-output-p' in emacs-25.1+
(while (not (string-match
org-babel-python-eoe-indicator
string-buffer))
(while (not (and (python-shell-comint-end-of-output-p string-buffer)
(string-match
org-babel-python-eoe-indicator
string-buffer)))
(accept-process-output (get-buffer-process (current-buffer))))
(org-babel-chomp (substring string-buffer 0 (match-beginning 0))))))
(defun org-babel-python-evaluate-session
(session body &optional result-type result-params)
(session body &optional result-type result-params graphics-file)
"Pass BODY to the Python 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."
string. If RESULT-TYPE equals `value' then return the value of
the last statement in BODY, as elisp. If GRAPHICS-FILE is
non-nil, then save graphical results to that file instead."
(let* ((tmp-src-file (org-babel-temp-file "python-"))
(results
(progn
(with-temp-file tmp-src-file (insert body))
(with-temp-file tmp-src-file
(insert (if (and graphics-file (eq result-type 'output))
(format org-babel-python--output-graphics-wrapper
body graphics-file)
body)))
(pcase result-type
(`output
(let ((body (format org-babel-python--exec-tmpfile
(let ((body (format "\
with open('%s') as f:
exec(compile(f.read(), f.name, 'exec'))"
(org-babel-process-file-name
tmp-src-file 'noquote))))
(org-babel-python--send-string session body)))
(org-babel-python-send-string session body)))
(`value
(let* ((tmp-results-file (org-babel-temp-file "python-"))
(let* ((results-file (or graphics-file
(org-babel-temp-file "python-")))
(body (org-babel-python-format-session-value
tmp-src-file tmp-results-file result-params)))
(org-babel-python--send-string session body)
(sleep-for 0.01)
(org-babel-eval-read-file tmp-results-file)))))))
tmp-src-file results-file result-params)))
(org-babel-python-send-string session body)
(sleep-for 0.010)
(org-babel-eval-read-file results-file)))))))
(org-babel-result-cond result-params
results
(org-babel-python-table-or-string results))))
(defun org-babel-python-read-string (string)
"Strip \\='s from around Python string."
"Strip \\='s from around Python STRING."
(if (and (string-prefix-p "'" string)
(string-suffix-p "'" string))
(substring string 1 -1)
@ -428,7 +531,7 @@ last statement in BODY, as elisp."
(org-babel-python-table-or-string results))))
(defun org-babel-python-async-evaluate-session
(session body &optional result-type result-params)
(session body &optional result-type result-params graphics-file)
"Asynchronously evaluate BODY in SESSION.
Returns a placeholder string for insertion, to later be replaced
by `org-babel-comint-async-filter'."
@ -436,28 +539,37 @@ by `org-babel-comint-async-filter'."
session (current-buffer)
"ob_comint_async_python_\\(.+\\)_\\(.+\\)"
'org-babel-chomp 'org-babel-python-async-value-callback)
(let ((python-shell-buffer-name (org-babel-python-without-earmuffs session)))
(pcase result-type
(`output
(let ((uuid (md5 (number-to-string (random 100000000)))))
(with-temp-buffer
(insert (format org-babel-python-async-indicator "start" uuid))
(insert "\n")
(insert body)
(insert "\n")
(insert (format org-babel-python-async-indicator "end" uuid))
(python-shell-send-buffer))
uuid))
(`value
(let ((tmp-results-file (org-babel-temp-file "python-"))
(tmp-src-file (org-babel-temp-file "python-")))
(with-temp-file tmp-src-file (insert body))
(with-temp-buffer
(insert (org-babel-python-format-session-value tmp-src-file tmp-results-file result-params))
(insert "\n")
(insert (format org-babel-python-async-indicator "file" tmp-results-file))
(python-shell-send-buffer))
tmp-results-file)))))
(pcase result-type
(`output
(let ((uuid (org-id-uuid)))
(with-temp-buffer
(insert (format org-babel-python-async-indicator "start" uuid))
(insert "\n")
(insert (if graphics-file
(format org-babel-python--output-graphics-wrapper
body graphics-file)
body))
(insert "\n")
(insert (format org-babel-python-async-indicator "end" uuid))
(let ((python-shell-buffer-name
(org-babel-python-without-earmuffs session)))
(python-shell-send-buffer)))
uuid))
(`value
(let ((results-file (or graphics-file
(org-babel-temp-file "python-")))
(tmp-src-file (org-babel-temp-file "python-")))
(with-temp-file tmp-src-file (insert body))
(with-temp-buffer
(insert (org-babel-python-format-session-value
tmp-src-file results-file result-params))
(insert "\n")
(unless graphics-file
(insert (format org-babel-python-async-indicator "file" results-file)))
(let ((python-shell-buffer-name
(org-babel-python-without-earmuffs session)))
(python-shell-send-buffer)))
results-file))))
(provide 'ob-python)

12
lisp/org/ob-ref.el
View file

@ -59,8 +59,9 @@
(declare-function org-babel-lob-get-info "ob-lob" (&optional datum no-eval))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-end-of-meta-data "org" (&optional full))
(declare-function org-find-property "org" (property &optional value))
(declare-function org-id-find-id-file "org-id" (id))
@ -155,8 +156,9 @@ Emacs Lisp representation of the value of 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))
(when (file-exists-p split-file)
(find-file split-file)
(setq ref split-ref)))
(org-with-wide-buffer
(goto-char (point-min))
(let* ((params (append args '((:results . "none"))))
@ -171,7 +173,7 @@ Emacs Lisp representation of the value of the variable."
(let ((e (org-element-at-point)))
(when (equal (org-element-property :name e) ref)
(goto-char
(org-element-property :post-affiliated e))
(org-element-post-affiliated e))
(pcase (org-element-type e)
(`babel-call
(throw :found

56
lisp/org/ob-ruby.el
View file

@ -73,7 +73,7 @@ It's possible to override it by using a header argument `:ruby'")
:type 'symbol)
(defun org-babel-execute:ruby (body params)
"Execute a block of Ruby code with Babel.
"Execute Ruby BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-ruby-initiate-session
(cdr (assq :session params)) params))
@ -86,7 +86,7 @@ This function is called by `org-babel-execute-src-block'."
body params (org-babel-variable-assignments:ruby params)))
(result (if (member "xmp" result-params)
(with-temp-buffer
(require 'rcodetools)
(org-require-package 'rcodetools "rcodetools (gem package)")
(insert full-body)
(xmp (cdr (assq :xmp-option params)))
(buffer-string))
@ -127,7 +127,8 @@ This function is called by `org-babel-execute-src-block'."
;; helper functions
(defun org-babel-variable-assignments:ruby (params)
"Return list of ruby statements assigning the block's variables."
"Return list of ruby statements assigning the block's variables.
The assignments are defined in PARAMS."
(mapcar
(lambda (pair)
(format "%s=%s"
@ -140,7 +141,7 @@ This function is called by `org-babel-execute-src-block'."
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 ", ") "]")
(concat "[" (mapconcat #'org-babel-ruby-var-to-ruby var ", \n") "]")
(if (eq var 'hline)
org-babel-ruby-hline-to
(format "%S" var))))
@ -152,20 +153,28 @@ Emacs-lisp table, otherwise return the results as a string."
(let ((res (org-babel-script-escape results)))
(if (listp res)
(mapcar (lambda (el) (if (not el)
org-babel-ruby-nil-to el))
org-babel-ruby-nil-to el))
res)
res)))
(defvar org-babel-ruby-prompt "_org_babel_ruby_prompt "
"String used for unique prompt.")
(defvar org-babel-ruby-define-prompt
(format "IRB.conf[:PROMPT][:CUSTOM] = { :PROMPT_I => \"%s\" }" org-babel-ruby-prompt))
(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."
then create one. Return the initialized session.
Session settings (`:ruby' header arg value) are taken from PARAMS."
(unless (string= session "none")
(require 'inf-ruby)
(org-require-package 'inf-ruby)
(let* ((command (cdr (or (assq :ruby params)
(assoc inf-ruby-default-implementation
inf-ruby-implementations))))
(buffer (get-buffer (format "*%s*" session)))
(new-session? (not buffer))
(session-buffer (or buffer (save-window-excursion
(run-ruby-or-pop-to-buffer
(if (functionp command)
@ -176,16 +185,32 @@ then create one. Return the initialized session."
(inf-ruby-buffer)))
(current-buffer)))))
(if (org-babel-comint-buffer-livep session-buffer)
(progn (sit-for .25) session-buffer)
(progn
(sit-for .25)
;; Setup machine-readable prompt: no echo, prompts matching
;; uniquely by regexp.
(when new-session?
(with-current-buffer session-buffer
(setq-local
org-babel-comint-prompt-regexp-old comint-prompt-regexp
comint-prompt-regexp (concat "^" org-babel-ruby-prompt))
(insert org-babel-ruby-define-prompt ";")
(insert "_org_prompt_mode=conf.prompt_mode;conf.prompt_mode=:CUSTOM;")
(insert "conf.echo=false\n")
(comint-send-input nil t)))
session-buffer)
(sit-for .5)
(org-babel-ruby-initiate-session session)))))
(defvar org-babel-ruby-eoe-indicator ":org_babel_ruby_eoe"
"String to indicate that evaluation has completed.")
(defvar org-babel-ruby-f-write
"File.open('%s','w'){|f| f.write((_.class == String) ? _ : _.inspect)}")
(defvar org-babel-ruby-pp-f-write
"File.open('%s','w'){|f| $stdout = f; pp(results); $stdout = orig_out}")
(defvar org-babel-ruby-wrapper-method
"
def main()
@ -194,6 +219,7 @@ end
results = main()
File.open('%s', 'w'){ |f| f.write((results.class == String) ? results : results.inspect) }
")
(defvar org-babel-ruby-pp-wrapper-method
"
require 'pp'
@ -237,7 +263,6 @@ return the value of the last statement in BODY, as elisp."
(org-babel-comint-with-output
(buffer org-babel-ruby-eoe-indicator t eoe-string)
(insert eoe-string) (comint-send-input nil t))
;; Now we can start the evaluation.
(mapconcat
#'identity
(butlast
@ -246,14 +271,9 @@ return the value of the last statement in BODY, as elisp."
#'org-trim
(org-babel-comint-with-output
(buffer org-babel-ruby-eoe-indicator t body)
(mapc
(lambda (line)
(insert (org-babel-chomp line)) (comint-send-input nil t))
(list "conf.echo=false;_org_prompt_mode=conf.prompt_mode;conf.prompt_mode=:NULL"
body
"conf.prompt_mode=_org_prompt_mode;conf.echo=true"
eoe-string)))
"\n") "[\r\n]") 4) "\n")))
(insert (org-babel-chomp body) "\n" eoe-string)
(comint-send-input nil t))
"\n") "[\r\n]")) "\n")))
(`value
(let* ((tmp-file (org-babel-temp-file "ruby-"))
(ppp (or (member "code" result-params)
@ -273,7 +293,7 @@ return the value of the last statement in BODY, as elisp."
"results=_" "require 'pp'" "orig_out = $stdout"
(format org-babel-ruby-pp-f-write
(org-babel-process-file-name tmp-file 'noquote))))
(list org-babel-ruby-eoe-indicator)))
(list (format "puts \"%s\"" org-babel-ruby-eoe-indicator))))
(comint-send-input nil t))
(org-babel-eval-read-file tmp-file))))))

119
lisp/org/ob-scheme.el
View file

@ -54,7 +54,7 @@
(defvar geiser-debug-jump-to-debug-p) ; Defined in geiser-debug.el
(defvar geiser-repl-use-other-window) ; Defined in geiser-repl.el
(defvar geiser-repl-window-allow-split) ; Defined in geiser-repl.el
(declare-function geiser-connect "ext:geiser-repl" (impl &optional host port))
(declare-function run-geiser "ext:geiser-repl" (impl))
(declare-function geiser "ext:geiser-repl" (impl))
(declare-function geiser-mode "ext:geiser-mode" ())
@ -65,6 +65,9 @@
(declare-function geiser-repl-exit "ext:geiser-repl" (&optional arg))
(declare-function geiser-eval--retort-output "ext:geiser-eval" (ret))
(declare-function geiser-eval--retort-result-str "ext:geiser-eval" (ret prefix))
(declare-function geiser-eval--retort-error "ext:geiser-eval" (ret))
(declare-function geiser-eval--retort-error-msg "ext:geiser-eval" (err))
(declare-function geiser-eval--error-msg "ext:geiser-eval" (err))
(defcustom org-babel-scheme-null-to 'hline
"Replace `null' and empty lists in scheme tables with this before returning."
@ -75,6 +78,17 @@
(defvar org-babel-default-header-args:scheme '()
"Default header arguments for scheme code blocks.")
(defconst org-babel-header-args:scheme '((host . :any)
(port . :any))
"Header arguments supported in Scheme.")
(defun org-babel-scheme-expand-header-arg-vars (vars)
"Expand :var header arguments given as VARS."
(mapconcat
(lambda (var)
(format "(define %S %S)" (car var) (cdr var)))
vars
"\n"))
(defun org-babel-expand-body:scheme (body params)
"Expand BODY according to PARAMS, return the expanded body."
@ -83,13 +97,7 @@
(postpends (cdr (assq :epilogue params))))
(concat (and prepends (concat prepends "\n"))
(if (null vars) body
(format "(let (%s)\n%s\n)"
(mapconcat
(lambda (var)
(format "%S" (print `(,(car var) ',(cdr var)))))
vars
"\n ")
body))
(concat (org-babel-scheme-expand-header-arg-vars vars) "\n" body))
(and postpends (concat "\n" postpends)))))
@ -116,13 +124,17 @@
(with-current-buffer (set-buffer buffer)
geiser-impl--implementation))
(defun org-babel-scheme-get-repl (impl name)
"Switch to a scheme REPL, creating it if it doesn't exist."
(defun org-babel-scheme-get-repl (impl name &optional host port)
"Switch to a Scheme REPL, creating it if it doesn't exist.
If the variables HOST and PORT are set, connect to the running Scheme REPL."
(let ((buffer (org-babel-scheme-get-session-buffer name)))
(or buffer
(progn
(if (fboundp 'geiser)
(geiser impl)
(if (and host port)
(geiser-connect impl host port)
(geiser impl))
;; Obsolete since Geiser 0.26.
(run-geiser impl))
(when name
@ -159,7 +171,7 @@ org-babel-scheme-execute-with-geiser will use a temporary session."
,@body
(current-message))))
(defun org-babel-scheme-execute-with-geiser (code output impl repl)
(defun org-babel-scheme-execute-with-geiser (code output impl repl &optional host port)
"Execute code in specified REPL.
If the REPL doesn't exist, create it using the given scheme
implementation.
@ -170,45 +182,58 @@ is true; otherwise returns the last value."
(with-temp-buffer
(insert (format ";; -*- geiser-scheme-implementation: %s -*-" impl))
(newline)
(insert code)
(geiser-mode)
(let ((geiser-repl-window-allow-split nil)
(geiser-repl-use-other-window nil))
(let ((repl-buffer (save-current-buffer
(org-babel-scheme-get-repl impl repl))))
(when (not (eq impl (org-babel-scheme-get-buffer-impl
(let ((beg (point)))
(insert code)
(geiser-mode)
(let ((geiser-repl-window-allow-split nil)
(geiser-repl-use-other-window nil))
(let ((repl-buffer (save-current-buffer
(org-babel-scheme-get-repl impl repl host port))))
(when (not (eq impl (org-babel-scheme-get-buffer-impl
(current-buffer))))
(message "Implementation mismatch: %s (%s) %s (%s)" impl (symbolp impl)
(org-babel-scheme-get-buffer-impl (current-buffer))
(symbolp (org-babel-scheme-get-buffer-impl
(current-buffer)))))
(setq geiser-repl--repl repl-buffer)
(setq geiser-impl--implementation nil)
(let ((geiser-debug-jump-to-debug-p nil)
(geiser-debug-show-debug-p nil))
;; `geiser-eval-region/wait' was introduced to await the
;; result of async evaluation in geiser version 0.22.
(let ((ret (funcall (if (fboundp 'geiser-eval-region/wait)
#'geiser-eval-region/wait
#'geiser-eval-region)
(point-min)
(point-max))))
(setq result (if output
(or (geiser-eval--retort-output ret)
"Geiser Interpreter produced no output")
(geiser-eval--retort-result-str ret "")))))
(when (not repl)
(save-current-buffer (set-buffer repl-buffer)
(geiser-repl-exit))
(set-process-query-on-exit-flag (get-buffer-process repl-buffer) nil)
(kill-buffer repl-buffer)))))
(message "Implementation mismatch: %s (%s) %s (%s)" impl (symbolp impl)
(org-babel-scheme-get-buffer-impl (current-buffer))
(symbolp (org-babel-scheme-get-buffer-impl
(current-buffer)))))
(setq geiser-repl--repl repl-buffer)
(setq geiser-impl--implementation nil)
(let ((geiser-debug-jump-to-debug-p nil)
(geiser-debug-show-debug-p nil))
;; `geiser-eval-region/wait' was introduced to await the
;; result of async evaluation in geiser version 0.22.
(let ((ret (funcall (if (fboundp 'geiser-eval-region/wait)
#'geiser-eval-region/wait
#'geiser-eval-region)
;; Do not include top comment into evaluation.
;; Apparently, mit-scheme has
;; problems with the top comment we add:
;; "Unexpected read restart on: #[textual-i/o-port 27 for console]"
beg
(point-max))))
(let ((err (geiser-eval--retort-error ret)))
(setq result (cond
(output
(or (geiser-eval--retort-output ret)
"Geiser Interpreter produced no output"))
(err nil)
(t (geiser-eval--retort-result-str ret ""))))
(when (not repl)
(save-current-buffer (set-buffer repl-buffer)
(geiser-repl-exit))
(set-process-query-on-exit-flag (get-buffer-process repl-buffer) nil)
(kill-buffer repl-buffer))
(when err
(let ((msg (geiser-eval--error-msg err)))
(org-babel-eval-error-notify
nil
(concat (if (listp msg) (car msg) msg) "\n")))))))))))
result))
(defun org-babel-scheme--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)))
(let ((res (and results (org-babel-script-escape results))))
(cond ((listp res)
(mapcar (lambda (el)
(if (or (null el) (eq el 'null))
@ -231,6 +256,8 @@ This function is called by `org-babel-execute-src-block'."
geiser-scheme-implementation
geiser-default-implementation
(car geiser-active-implementations)))
(host (cdr (assq :host params)))
(port (cdr (assq :port params)))
(session (org-babel-scheme-make-session-name
source-buffer-name (cdr (assq :session params)) impl))
(full-body (org-babel-expand-body:scheme body params))
@ -240,7 +267,9 @@ This function is called by `org-babel-execute-src-block'."
full-body ; code
(string= result-type "output") ; output?
impl ; implementation
(and (not (string= session "none")) session)))) ; session
(and (not (string= session "none")) session) ; session
host ; REPL host
port))) ; REPL port
(let ((table
(org-babel-reassemble-table
result

4
lisp/org/ob-screen.el
View file

@ -50,8 +50,8 @@ In case you want to use a different screen than one selected by your $PATH")
"Default arguments to use when running screen source blocks.")
(defun org-babel-execute:screen (body params)
"Send a block of code via screen to a terminal using Babel.
\"default\" session is used when none is specified."
"Send BODY via screen to a terminal using Babel, according to PARAMS.
\"default\" session is used when none is specified in the PARAMS."
(message "Sending source code block to interactive terminal session...")
(save-window-excursion
(let* ((session (cdr (assq :session params)))

120
lisp/org/ob-shell.el
View file

@ -3,6 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Maintainer: Matthew Trzcinski <matt@excalamus.com>
;; Keywords: literate programming, reproducible research
;; URL: https://orgmode.org
@ -44,6 +45,11 @@
(declare-function orgtbl-to-generic "org-table" (table params))
(defvar org-babel-default-header-args:shell '())
(defconst org-babel-header-args:shell
'((async . ((yes no))))
"Shell-specific header arguments.")
(defvar org-babel-shell-names)
(defconst org-babel-shell-set-prompt-commands
@ -51,8 +57,6 @@
("fish" . "function fish_prompt\n\techo \"%s\"\nend")
;; prompt2 is like PS2 in POSIX shells.
("csh" . "set prompt=\"%s\"\nset prompt2=\"\"")
;; PowerShell, similar to fish, does not have PS2 equivalent.
("posh" . "function prompt { \"%s\" }")
;; PROMPT_COMMAND can override PS1 settings. Disable it.
;; Disable PS2 to avoid garbage in multi-line inputs.
(t . "PROMPT_COMMAND=;PS1=\"%s\";PS2="))
@ -66,28 +70,32 @@ that will be called with a single additional argument: prompt string.
The fallback association template is defined in (t . \"template\")
alist element.")
(defvar org-babel-prompt-command)
(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-prompt-command
(or (cdr (assoc ,name org-babel-shell-set-prompt-commands))
(alist-get t org-babel-shell-set-prompt-commands))))
(org-babel-execute:shell body params))))
(eval `(defalias ',(intern (concat "org-babel-variable-assignments:" name))
'org-babel-variable-assignments:shell
,(format "Return list of %s statements assigning to the block's \
(let ((fname (intern (concat "org-babel-execute:" name))))
(defalias fname
(lambda (body params)
(:documentation
(format "Execute a block of %s commands with Babel." name))
(let ((explicit-shell-file-name name)
(shell-file-name name))
(org-babel-execute:shell body params))))
(put fname 'definition-name 'org-babel-shell-initialize))
(defalias (intern (concat "org-babel-variable-assignments:" name))
#'org-babel-variable-assignments:shell
(format "Return list of %s statements assigning to the block's \
variables."
name)))
(eval `(defvar ,(intern (concat "org-babel-default-header-args:" name)) '()))))
name))
(funcall (if (fboundp 'defvar-1) #'defvar-1 #'set) ;Emacs-29
(intern (concat "org-babel-default-header-args:" name))
nil)
(funcall (if (fboundp 'defvar-1) #'defvar-1 #'set) ;Emacs-29
(intern (concat "org-babel-header-args:" name))
nil)))
(defcustom org-babel-shell-names
'("sh" "bash" "zsh" "fish" "csh" "ash" "dash" "ksh" "mksh" "posh")
@ -114,7 +122,7 @@ a shell execution being its exit code."
:package-version '(Org . "9.4"))
(defun org-babel-execute:shell (body params)
"Execute a block of Shell commands with Babel.
"Execute Shell BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-sh-initiate-session
(cdr (assq :session params))))
@ -261,22 +269,38 @@ var of the same value."
(org-babel-comint-wait-for-output (current-buffer))
(org-babel-comint-input-command
(current-buffer)
(format org-babel-prompt-command org-babel-sh-prompt))
(setq-local comint-prompt-regexp
(concat "^" (regexp-quote org-babel-sh-prompt)
" *"))
(format
(or (cdr (assoc (file-name-nondirectory shell-file-name)
org-babel-shell-set-prompt-commands))
(alist-get t org-babel-shell-set-prompt-commands))
org-babel-sh-prompt))
(setq-local
org-babel-comint-prompt-regexp-old comint-prompt-regexp
comint-prompt-regexp
(concat "^" (regexp-quote org-babel-sh-prompt)
" *"))
;; Needed for Emacs 23 since the marker is initially
;; undefined and the filter functions try to use it without
;; checking.
(set-marker comint-last-output-start (point))
(get-buffer (current-buffer)))))))
(defconst ob-shell-async-indicator "echo 'ob_comint_async_shell_%s_%s'"
"Session output delimiter template.
See `org-babel-comint-async-indicator'.")
(defun ob-shell-async-chunk-callback (string)
"Filter applied to results before insertion.
See `org-babel-comint-async-chunk-callback'."
(replace-regexp-in-string comint-prompt-regexp "" string))
(defun org-babel-sh-evaluate (session body &optional params stdin cmdline)
"Pass BODY to the Shell process in BUFFER.
If RESULT-TYPE equals `output' then return a list of the outputs
of the statements in BODY, if RESULT-TYPE equals `value' then
return the value of the last statement in BODY."
(let* ((shebang (cdr (assq :shebang params)))
(async (org-babel-comint-use-async params))
(results-params (cdr (assq :result-params params)))
(value-is-exit-status
(or (and
@ -308,19 +332,37 @@ return the value of the last statement in BODY."
(concat (file-local-name script-file) " " cmdline)))))
(buffer-string))))
(session ; session evaluation
(mapconcat
#'org-babel-sh-strip-weird-long-prompt
(mapcar
#'org-trim
(butlast ; Remove eoe indicator
(org-babel-comint-with-output
(session org-babel-sh-eoe-output t body)
(insert (org-trim body) "\n"
org-babel-sh-eoe-indicator)
(comint-send-input nil t))
;; Remove `org-babel-sh-eoe-indicator' output line.
1))
"\n"))
(if async
(progn
(let ((uuid (org-id-uuid)))
(org-babel-comint-async-register
session
(current-buffer)
"ob_comint_async_shell_\\(.+\\)_\\(.+\\)"
'ob-shell-async-chunk-callback
nil)
(org-babel-comint-async-delete-dangling-and-eval
session
(insert (format ob-shell-async-indicator "start" uuid))
(comint-send-input nil t)
(insert (org-trim body))
(comint-send-input nil t)
(insert (format ob-shell-async-indicator "end" uuid))
(comint-send-input nil t))
uuid))
(mapconcat
#'org-babel-sh-strip-weird-long-prompt
(mapcar
#'org-trim
(butlast ; Remove eoe indicator
(org-babel-comint-with-output
(session org-babel-sh-eoe-output t body)
(insert (org-trim body) "\n"
org-babel-sh-eoe-indicator)
(comint-send-input nil t))
;; Remove `org-babel-sh-eoe-indicator' output line.
1))
"\n")))
;; External shell script, with or without a predefined
;; shebang.
((org-string-nw-p shebang)
@ -331,7 +373,13 @@ return the value of the last statement in BODY."
(when padline (insert "\n"))
(insert body))
(set-file-modes script-file #o755)
(org-babel-eval script-file "")))
(if (file-remote-p script-file)
;; Run remote script using its local path as COMMAND.
;; The remote execution is ensured by setting
;; correct `default-directory'.
(let ((default-directory (file-name-directory script-file)))
(org-babel-eval (file-local-name script-file) ""))
(org-babel-eval script-file ""))))
(t (org-babel-eval shell-file-name (org-trim body))))))
(when (and results value-is-exit-status)
(setq results (car (reverse (split-string results "\n" t)))))

10
lisp/org/ob-sql.el
View file

@ -113,9 +113,7 @@
Set `sql-product' in Org edit buffer according to the
corresponding :engine source block header argument."
(let ((product (cdr (assq :engine (nth 2 info)))))
(condition-case nil
(sql-set-product product)
(user-error "Cannot set `sql-product' in Org Src edit buffer"))))
(sql-set-product product)))
(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."
@ -409,11 +407,11 @@ argument mechanism."
val (if sqlite
nil
'(:fmt (lambda (el) (if (stringp el)
el
(format "%S" el))))))))
el
(format "%S" el))))))))
data-file)
(if (stringp val) val (format "%S" val))))
body)))
body t t)))
vars)
body)

21
lisp/org/ob-sqlite.el
View file

@ -57,13 +57,20 @@
(defun org-babel-expand-body:sqlite (body params)
"Expand BODY according to the values of PARAMS."
(org-babel-sql-expand-vars
body (org-babel--get-vars params) t))
(let ((prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params))))
(mapconcat 'identity
(list
prologue
(org-babel-sql-expand-vars
body (org-babel--get-vars params) t)
epilogue)
"\n")))
(defvar org-babel-sqlite3-command "sqlite3")
(defun org-babel-execute:sqlite (body params)
"Execute a block of Sqlite code with Babel.
"Execute Sqlite BODY according to PARAMS.
This function is called by `org-babel-execute-src-block'."
(let ((result-params (split-string (or (cdr (assq :results params)) "")))
(db (cdr (assq :db params)))
@ -74,7 +81,6 @@ This function is called by `org-babel-execute-src-block'."
(lambda (arg) (car (assq arg params)))
(list :header :echo :bail :column
:csv :html :line :list)))))
(unless db (error "ob-sqlite: can't evaluate without a database"))
(with-temp-buffer
(insert
(org-babel-eval
@ -97,7 +103,7 @@ This function is called by `org-babel-execute-src-block'."
(member :html others) separator)
""
"-csv"))
(cons "db " db)))
(cons "db" (or db ""))))
;; body of the code block
(org-babel-expand-body:sqlite body params)))
(org-babel-result-cond result-params
@ -122,7 +128,8 @@ This function is called by `org-babel-execute-src-block'."
(org-babel-sql-expand-vars body vars t))
(defun org-babel-sqlite-table-or-scalar (result)
"If RESULT looks like a trivial table, then unwrap it."
"Cleanup cells in the RESULT table.
If RESULT is a trivial 1x1 table, then unwrap it."
(if (and (equal 1 (length result))
(equal 1 (length (car result))))
(org-babel-read (caar result) t)
@ -133,7 +140,7 @@ This function is called by `org-babel-execute-src-block'."
result)))
(defun org-babel-sqlite-offset-colnames (table headers-p)
"If HEADERS-P is non-nil then offset the first row as column names."
"If HEADERS-P is non-nil then offset the first row as column names in TABLE."
(if headers-p
(cons (car table) (cons 'hline (cdr table)))
table))

24
lisp/org/ob-table.el
View file

@ -87,18 +87,20 @@ is the equivalent of the following source code block:
results
#+end_src
NOTE: The quotation marks around the function name,
`source-block', are optional.
The quotation marks around the function name, `source-block', are
optional.
NOTE: By default, string variable names are interpreted as
references to source-code blocks, to force interpretation of a
cell's value as a string, prefix the identifier a \"$\" (e.g.,
\"$$2\" instead of \"$2\" or \"$@2$2\" instead of \"@2$2\").
By default, string variable names are interpreted as references to
source-code blocks, to force interpretation of a cell's value as a
string, prefix the identifier a \"$\" (e.g., \"$$2\" instead of \"$2\"
or \"$@2$2\" instead of \"@2$2\"). \"$\" will also force interpreting
string value literally: $\"value\" will refer to a string, not a
source block name.
NOTE: It is also possible to pass header arguments to the code
block. In this case a table cell should hold the string value of
the header argument which can then be passed before all variables
as shown in the example below.
It is also possible to pass header arguments to the code block. In
this case a table cell should hold the string value of the header
argument which can then be passed before all variables as shown in the
example below.
| 1 | 2 | :file nothing.png | nothing.png |
#+TBLFM: @1$4=\\='(org-sbe test-sbe $3 (x $1) (y $2))"
@ -117,7 +119,7 @@ as shown in the example below.
(prog1 nil (setq quote t))
(prog1
(cond
(quote (format "\"%s\"" el))
(quote (format "%S" el))
((stringp el) (org-no-properties el))
(t el))
(setq quote nil))))

133
lisp/org/ob-tangle.el
View file

@ -40,11 +40,11 @@
(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-element--cache-active-p "org-element" ())
(declare-function org-element-lineage "org-element" (datum &optional types with-self))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-lineage "org-element-ast" (datum &optional types with-self))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-heading-components "org" ())
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
(declare-function org-in-archived-heading-p "org" (&optional no-inheritance))
@ -166,6 +166,23 @@ read-write permissions for the user, read-only for everyone else."
:package-version '(Org . "9.6")
:type 'integer)
(defcustom org-babel-tangle-remove-file-before-write 'auto
"How to overwrite the existing tangle target.
When set to nil, `org-babel-tangle' will replace contents of an existing
tangle target (and fail when tangle target is read-only).
When set to t, the tangle target (including read-only) will be deleted
first and a new file, possibly with different ownership and
permissions, will be created.
When set to symbol `auto', overwrite read-only tangle targets and
replace contents otherwise."
:group 'org-babel-tangle
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Replace contents, but keep the same file" nil)
(const :tag "Re-create file" t)
(const :tag "Re-create when read-only" auto))
:safe t)
(defun org-babel-find-file-noselect-refresh (file)
"Find file ensuring that the latest changes on disk are
represented in the file."
@ -205,21 +222,20 @@ source code blocks by languages matching a regular expression.
Return list of the tangled file names."
(interactive "fFile to tangle: \nP")
(let* ((visited (find-buffer-visiting file))
(buffer (or visited (find-file-noselect file))))
(prog1
(with-current-buffer buffer
(org-with-wide-buffer
(mapcar #'expand-file-name
(org-babel-tangle nil target-file lang-re))))
(unless visited (kill-buffer buffer)))))
(org-with-file-buffer file
(org-with-wide-buffer
(mapcar #'expand-file-name
(org-babel-tangle nil target-file lang-re)))))
(defun org-babel-tangle-publish (_ filename pub-dir)
"Tangle FILENAME and place the results in PUB-DIR."
(unless (file-exists-p pub-dir)
(make-directory pub-dir t))
(setq pub-dir (file-name-as-directory pub-dir))
(mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename)))
;; Rename files to avoid copying to same file when publishing to ./
;; `copy-file' would throw an error when copying file to self.
(mapc (lambda (el) (rename-file el pub-dir t))
(org-babel-tangle-file filename)))
;;;###autoload
(defun org-babel-tangle (&optional arg target-file lang-re)
@ -253,7 +269,8 @@ matching a regular expression."
(when (equal arg '(16))
(or (cdr (assq :tangle (nth 2 (org-babel-get-src-block-info 'no-eval))))
(user-error "Point is not in a source code block"))))
path-collector)
path-collector
(source-file buffer-file-name))
(mapc ;; map over file-names
(lambda (by-fn)
(let ((file-name (car by-fn)))
@ -310,10 +327,28 @@ matching a regular expression."
(compare-buffer-substrings
nil nil nil
tangle-buf nil nil)))))))
;; erase previous file
(when (file-exists-p file-name)
(when (equal (if (file-name-absolute-p file-name)
file-name
(expand-file-name file-name))
(if (file-name-absolute-p source-file)
source-file
(expand-file-name source-file)))
(error "Not allowed to tangle into the same file as self"))
;; We do not erase, but overwrite previous file
;; to preserve any existing symlinks.
;; This behavior is modified using
;; `org-babel-tangle-remove-file-before-write' to
;; tangle to read-only files.
(when (and
(file-exists-p file-name)
(pcase org-babel-tangle-remove-file-before-write
(`auto (not (file-writable-p file-name)))
(`t t)
(`nil nil)
(_ (error "Invalid value of `org-babel-tangle-remove-file-before-write': %S"
org-babel-tangle-remove-file-before-write))))
(delete-file file-name))
(write-region nil nil file-name)
(write-region nil nil file-name)
(mapc (lambda (mode) (set-file-modes file-name mode)) modes))
(push file-name path-collector))))))
(if (equal arg '(4))
@ -378,7 +413,7 @@ references."
(goto-char (point-min))
(while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t)
(re-search-forward (org-babel-noweb-wrap) nil t))
(delete-region (save-excursion (beginning-of-line 1) (point))
(delete-region (save-excursion (forward-line) (point))
(save-excursion (end-of-line 1) (forward-char 1) (point)))))
(defun org-babel-spec-to-string (spec)
@ -427,17 +462,19 @@ that the appropriate major-mode is set. SPEC has the form:
org-babel-tangle-comment-format-end link-data)))))
(defun org-babel-effective-tangled-filename (buffer-fn src-lang src-tfile)
"Return effective tangled filename of a source-code block.
BUFFER-FN is the name of the buffer, SRC-LANG the language of the
block and SRC-TFILE is the value of the :tangle header argument,
as computed by `org-babel-tangle-single-block'."
(let ((base-name (cond
((string= "yes" src-tfile)
;; Use the buffer name
(file-name-sans-extension buffer-fn))
((string= "no" src-tfile) nil)
((> (length src-tfile) 0) src-tfile)))
(ext (or (cdr (assoc src-lang org-babel-tangle-lang-exts)) src-lang)))
"Return effective tangled absolute filename of a source-code block.
BUFFER-FN is the absolute file name of the buffer, SRC-LANG the
language of the block and SRC-TFILE is the value of the :tangle
header argument, as computed by `org-babel-tangle-single-block'."
(let* ((fnd (file-name-directory buffer-fn))
(base-name (cond
((string= "yes" src-tfile)
;; Use the buffer name
(file-name-sans-extension buffer-fn))
((string= "no" src-tfile) nil)
((> (length src-tfile) 0)
(expand-file-name src-tfile fnd))))
(ext (or (cdr (assoc src-lang org-babel-tangle-lang-exts)) src-lang)))
(when base-name
;; decide if we want to add ext to base-name
(if (and ext (string= "yes" src-tfile))
@ -454,13 +491,16 @@ source code blocks by languages matching a regular expression.
Optional argument TANGLE-FILE can be used to limit the collected
code blocks by target file."
(let ((counter 0) last-heading-pos blocks)
(let ((counter 0)
(buffer-fn (buffer-file-name (buffer-base-buffer)))
last-heading-pos blocks)
(org-babel-map-src-blocks (buffer-file-name)
(let ((current-heading-pos
(if (org-element--cache-active-p)
(or (org-element-property :begin (org-element-lineage (org-element-at-point) '(headline) t)) 1)
(org-with-wide-buffer
(org-with-limited-levels (outline-previous-heading))))))
(or (org-element-begin
(org-element-lineage
(org-element-at-point)
'headline t))
1)))
(if (eq last-heading-pos current-heading-pos) (cl-incf counter)
(setq counter 1)
(setq last-heading-pos current-heading-pos)))
@ -470,6 +510,7 @@ code blocks by target file."
(src-lang (nth 0 info))
(src-tfile (cdr (assq :tangle (nth 2 info)))))
(unless (or (string= src-tfile "no")
(not src-lang) ;; src block without lang
(and tangle-file (not (equal tangle-file src-tfile)))
(and lang-re (not (string-match-p lang-re src-lang))))
;; Add the spec for this block to blocks under its tangled
@ -477,7 +518,7 @@ code blocks by target file."
(let* ((block (org-babel-tangle-single-block counter))
(src-tfile (cdr (assq :tangle (nth 4 block))))
(file-name (org-babel-effective-tangled-filename
(nth 1 block) src-lang src-tfile))
buffer-fn src-lang src-tfile))
(by-fn (assoc file-name blocks)))
(if by-fn (setcdr by-fn (cons (cons src-lang block) (cdr by-fn)))
(push (cons file-name (list (cons src-lang block))) blocks)))))))
@ -491,12 +532,7 @@ code blocks by target file."
The PARAMS are the 3rd element of the info for the same src block."
(unless (string= "no" (cdr (assq :comments params)))
(save-match-data
(let* (;; The created link is transient. Using ID is not necessary,
;; but could have side-effects if used. An ID property may
;; be added to existing entries thus creating unexpected file
;; modifications.
(org-id-link-to-org-use-id nil)
(l (org-no-properties
(let* ((l (org-no-properties
(cl-letf (((symbol-function 'org-store-link-functions)
(lambda () nil)))
(org-store-link nil))))
@ -589,13 +625,12 @@ non-nil, return the full association list to be used by
link
source-name
params
(if org-src-preserve-indentation
(org-trim body t)
(if (org-src-preserve-indentation-p) (org-trim body t)
(org-trim (org-remove-indentation body)))
comment)))
(if only-this-block
(let* ((file-name (org-babel-effective-tangled-filename
(nth 1 result) src-lang src-tfile)))
file src-lang src-tfile)))
(list (cons file-name (list (cons src-lang result)))))
result)))
@ -616,9 +651,12 @@ by `org-babel-get-src-block-info'."
;; de-tangling functions
(defun org-babel-detangle (&optional source-code-file)
"Propagate changes in source file back original to Org file.
"Propagate changes from current source buffer back to the original Org file.
This requires that code blocks were tangled with link comments
which enable the original code blocks to be found."
which enable the original code blocks to be found.
Optional argument SOURCE-CODE-FILE is the file path to be used instead
of the current buffer."
(interactive)
(save-excursion
(when source-code-file (find-file source-code-file))
@ -673,8 +711,7 @@ which enable the original code blocks to be found."
(org-back-to-heading t))
;; Do not skip the first block if it begins at point min.
(cond ((or (org-at-heading-p)
(not (eq (org-element-type (org-element-at-point))
'src-block)))
(not (org-element-type-p (org-element-at-point) 'src-block)))
(org-babel-next-src-block n))
((= n 1))
(t (org-babel-next-src-block (1- n)))))

186
lisp/org/oc-basic.el
View file

@ -1,4 +1,4 @@
;;; oc-basic.el --- basic back-end for citations -*- lexical-binding: t; -*-
;;; oc-basic.el --- basic backend for citations -*- lexical-binding: t; -*-
;; Copyright (C) 2021-2024 Free Software Foundation, Inc.
@ -78,9 +78,19 @@
(declare-function org-open-at-point "org" (&optional arg))
(declare-function org-open-file "org" (path &optional in-emacs line search))
(declare-function org-element-create "org-element-ast" (type &optional props &rest children))
(declare-function org-element-set "org-element-ast" (old new &optional keep-props))
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
(declare-function org-element-map "org-element"
( data types fun
&optional
info first-match no-recursion
with-affiliated no-undefer))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-element-contents "org-element-ast" (node))
(declare-function org-export-data "org-export" (data info))
(declare-function org-export-derived-backend-p "org-export" (backend &rest backends))
@ -272,6 +282,9 @@ Optional argument INFO is the export state, as a property list."
(plist-get info :cite-basic/bibliography)
(let ((results nil))
(dolist (file (org-cite-list-bibliography-files))
;; Follow symlinks, to look into modification time of the
;; actual file, not its symlink.
(setq file (file-truename file))
(when (file-readable-p file)
(with-temp-buffer
(when (or (org-file-has-changed-p file)
@ -330,9 +343,11 @@ FIELD is a symbol. ENTRY-OR-KEY is either an association list, as returned by
Optional argument INFO is the export state, as a property list.
Return value may be nil or a string. If current export back-end is derived
from `latex', return a raw string instead, unless optional argument RAW is
non-nil."
Return value may be nil or a string. If current export backend is derived
from `latex', return a raw string object instead, unless optional
argument RAW is non-nil.
Throw an error if the field value is non-string and non-nil."
(let ((value
(cdr
(assq field
@ -343,6 +358,8 @@ non-nil."
entry-or-key)
(_
(error "Wrong value for ENTRY-OR-KEY: %S" entry-or-key)))))))
(when (and value (not (stringp value)))
(error "Non-string bibliography field value: %S" value))
(if (and value
(not raw)
(org-export-derived-backend-p (plist-get info :back-end) 'latex))
@ -351,17 +368,27 @@ non-nil."
(defun org-cite-basic--shorten-names (names)
"Return a list of family names from a list of full NAMES.
NAMES can be a string or raw string object.
To better accomomodate corporate names, this will only shorten
personal names of the form \"family, given\"."
(when (stringp names)
(mapconcat
(lambda (name)
(if (eq 1 (length name))
(cdr (split-string name))
(car (split-string name ", "))))
(split-string names " and ")
", ")))
(let (names-string raw-p)
(cond
((stringp names) (setq names-string names))
((org-element-type-p names 'raw)
(setq names-string (mapconcat #'identity (org-element-contents names) "")
raw-p t)))
(when names-string
(setq names-string
(mapconcat
(lambda (name)
(if (eq 1 (length name))
(cdr (split-string name))
(car (split-string name ", "))))
(split-string names-string " and ")
", "))
(if raw-p (org-export-raw-string names-string)
names-string))))
(defun org-cite-basic--number-to-suffix (n)
"Compute suffix associated to number N.
@ -417,7 +444,7 @@ necessary, unless optional argument NO-SUFFIX is non-nil."
(year
(or (org-cite-basic--get-field 'year entry-or-key info 'raw)
(let ((date
(org-cite-basic--get-field 'date entry-or-key info t)))
(org-cite-basic--get-field 'date entry-or-key info 'raw)))
(and (stringp date)
(string-match (rx string-start
(group (= 4 digit))
@ -445,6 +472,38 @@ necessary, unless optional argument NO-SUFFIX is non-nil."
new))))
(if no-suffix year (concat year suffix)))))))
(defun org-cite-basic--print-bibtex-string (element &optional info)
"Print Bibtex formatted string ELEMENT, according to Bibtex syntax.
Remove all the {...} that are not a part of LaTeX macros and parse the
LaTeX fragments. Do nothing when current backend is derived from
LaTeX, according to INFO.
Return updated ELEMENT."
(if (org-export-derived-backend-p (plist-get info :back-end) 'latex)
;; Derived from LaTeX, no need to use manual ad-hoc LaTeX
;; parser.
element
;; Convert ELEMENT to anonymous when ELEMENT is string.
;; Otherwise, we cannot modify ELEMENT by side effect.
(when (org-element-type-p element 'plain-text)
(setq element (org-element-create 'anonymous nil element)))
;; Approximately parse LaTeX fragments, assuming Org mode syntax
;; (it is close to original LaTeX, and we do not want to
;; re-implement complete LaTeX parser here))
(org-element-map element t
(lambda (str)
(when (stringp str)
(org-element-set
str
(org-element-parse-secondary-string
str '(latex-fragment entity))))))
;; Strip the remaining { and }.
(org-element-map element t
(lambda (str)
(when (stringp str)
(org-element-set str (replace-regexp-in-string "[{}]" "" str)))))
element))
(defun org-cite-basic--print-entry (entry style &optional info)
"Format ENTRY according to STYLE string.
ENTRY is an alist, as returned by `org-cite-basic--get-entry'.
@ -456,27 +515,29 @@ Optional argument INFO is the export state, as a property list."
(org-cite-basic--get-field 'journal entry info)
(org-cite-basic--get-field 'institution entry info)
(org-cite-basic--get-field 'school entry info))))
(pcase style
("plain"
(let ((year (org-cite-basic--get-year entry info 'no-suffix)))
(org-cite-concat
(org-cite-basic--shorten-names author) ". "
title (and from (list ", " from)) ", " year ".")))
("numeric"
(let ((n (org-cite-basic--key-number (cdr (assq 'id entry)) info))
(year (org-cite-basic--get-year entry info 'no-suffix)))
(org-cite-concat
(format "[%d] " n) author ", "
(org-cite-emphasize 'italic title)
(and from (list ", " from)) ", "
year ".")))
;; Default to author-year. Use year disambiguation there.
(_
(let ((year (org-cite-basic--get-year entry info)))
(org-cite-concat
author " (" year "). "
(org-cite-emphasize 'italic title)
(and from (list ", " from)) "."))))))
(org-cite-basic--print-bibtex-string
(pcase style
("plain"
(let ((year (org-cite-basic--get-year entry info 'no-suffix)))
(org-cite-concat
(org-cite-basic--shorten-names author) ". "
title (and from (list ", " from)) ", " year ".")))
("numeric"
(let ((n (org-cite-basic--key-number (cdr (assq 'id entry)) info))
(year (org-cite-basic--get-year entry info 'no-suffix)))
(org-cite-concat
(format "[%d] " n) author ", "
(org-cite-emphasize 'italic title)
(and from (list ", " from)) ", "
year ".")))
;; Default to author-year. Use year disambiguation there.
(_
(let ((year (org-cite-basic--get-year entry info)))
(org-cite-concat
author " (" year "). "
(org-cite-emphasize 'italic title)
(and from (list ", " from)) "."))))
info)))
;;; "Activate" capability
@ -580,8 +641,8 @@ INFO is the export state, as a property list."
(suffix (org-element-property :suffix ref)))
(funcall format-ref
prefix
(org-cite-basic--get-author k info)
(org-cite-basic--get-year k info)
(or (org-cite-basic--get-author k info) "??")
(or (org-cite-basic--get-year k info) "????")
suffix)))
(org-cite-get-references citation)
org-cite-basic-author-year-separator)
@ -619,7 +680,7 @@ INFO is the export state as a property list."
INFO is the export state, as a property list."
(and field
(lambda (a b)
(string-collate-lessp
(org-string<
(org-cite-basic--get-field field a info 'raw)
(org-cite-basic--get-field field b info 'raw)
nil t))))
@ -649,20 +710,30 @@ export communication channel, as a property list."
;; "author" style.
(`(,(or "author" "a") . ,variant)
(let ((caps (member variant '("caps" "c"))))
(org-export-data
(mapconcat
(lambda (key)
(let ((author (org-cite-basic--get-author key info)))
(if caps (capitalize author) author)))
(org-cite-get-references citation t)
org-cite-basic-author-year-separator)
(org-cite-basic--format-author-year
citation
(lambda (p c s) (org-cite-concat p c s))
(lambda (prefix author _ suffix)
(org-cite-concat
prefix
(if caps (org-cite-capitalize author) author)
suffix))
info)))
;; "noauthor" style.
(`(,(or "noauthor" "na") . ,variant)
(format (if (funcall has-variant-p variant 'bare) "%s" "(%s)")
(mapconcat (lambda (key) (org-cite-basic--get-year key info))
(org-cite-get-references citation t)
org-cite-basic-author-year-separator)))
(let ((bare? (funcall has-variant-p variant 'bare)))
(org-cite-basic--format-author-year
citation
(lambda (prefix contents suffix)
(org-cite-concat
(unless bare? "(")
prefix
contents
suffix
(unless bare? ")")))
(lambda (prefix _ year suffix)
(org-cite-concat prefix year suffix))
info)))
;; "nocite" style.
(`(,(or "nocite" "n") . ,_) nil)
;; "text" and "note" styles.
@ -678,10 +749,11 @@ export communication channel, as a property list."
(lambda (p c s) (org-cite-concat p c s))
(lambda (p a y s)
(org-cite-concat p
(if caps (capitalize a) a)
(if caps (org-cite-capitalize a) a)
(if bare " " " (")
y s
(and (not bare) ")")))
y
(and (not bare) ")")
s))
info)))
;; "numeric" style.
;;
@ -702,7 +774,7 @@ export communication channel, as a property list."
(lambda (p c s)
(org-cite-concat (and (not bare) "(") p c s (and (not bare) ")")))
(lambda (p a y s)
(org-cite-concat p (if caps (capitalize a) a) ", " y s))
(org-cite-concat p (if caps (org-cite-capitalize a) a) ", " y s))
info)))
;; This should not happen.
(_ (error "Invalid style: %S" style)))))
@ -710,7 +782,7 @@ export communication channel, as a property list."
(defun org-cite-basic-export-bibliography (keys _files style _props backend info)
"Generate bibliography.
KEYS is the list of cited keys, as strings. STYLE is the expected bibliography
style, as a string. BACKEND is the export back-end, as a symbol. INFO is the
style, as a string. BACKEND is the export backend, as a symbol. INFO is the
export state, as a property list."
(mapconcat
(lambda (entry)
@ -734,7 +806,7 @@ When DATUM is a citation reference, open bibliography entry referencing
the citation key. Otherwise, select which key to follow among all keys
present in the citation."
(let* ((key
(if (eq 'citation-reference (org-element-type datum))
(if (org-element-type-p datum 'citation-reference)
(org-element-property :key datum)
(pcase (org-cite-get-references datum t)
(`(,key) key)
@ -806,7 +878,7 @@ Return nil if there are no bibliography files or no entries."
(let ((date (org-cite-basic--get-year entry nil 'no-suffix)))
(format "%4s" (or date "")))
org-cite-basic-column-separator
(org-cite-basic--get-field 'title entry nil t))))
(org-cite-basic--get-field 'title entry nil 'raw))))
(puthash completion key org-cite-basic--completion-cache)))
(unless (map-empty-p org-cite-basic--completion-cache) ;no key
(puthash entries t org-cite-basic--completion-cache)

36
lisp/org/oc-biblatex.el
View file

@ -70,7 +70,8 @@
(require 'org-macs)
(require 'oc)
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-parent "org-element-ast" (node))
(declare-function org-export-data "org-export" (data info))
@ -189,20 +190,23 @@ INITIAL is an initial style of comma-separated options, as a string or nil.
STYLE is the style definition as a string or nil.
Return a string."
(let ((options-no-style
(and initial
(let ((re (rx string-start (or "bibstyle" "citestyle" "style"))))
(seq-filter
(lambda (option) (not (string-match re option)))
(split-string (org-unbracket-string "[" "]" initial)
"," t " \t")))))
(style-options
(cond
((null style) nil)
((not (string-match "/" style)) (list (concat "style=" style)))
(t
(list (concat "bibstyle=" (substring style nil (match-beginning 0)))
(concat "citestyle=" (substring style (match-end 0))))))))
(let* ((options-no-style
(and initial
(let ((re (rx string-start (or "bibstyle" "citestyle" "style"))))
(seq-filter
(lambda (option) (not (string-match re option)))
(split-string (org-unbracket-string "[" "]" initial)
"," t " \t")))))
;; Check whether the string is in key=val,...
(biblatex-options-p (and (stringp style) (string-match-p "\\`[^,=]+=[^,]+\\(,[^=]+=[^,]+\\)\\'" style)))
(style-options
(cond
((null style) nil)
;; Assume it is a valid options string for biblatex if it is in key=val,... format
((not (string-match "/" style)) (list (if biblatex-options-p style (concat "style=" style))))
(t
(list (concat "bibstyle=" (substring style nil (match-beginning 0)))
(concat "citestyle=" (substring style (match-end 0))))))))
(if (or options-no-style style-options)
(format "[%s]"
(mapconcat #'identity
@ -231,7 +235,7 @@ When NO-OPT argument is non-nil, only provide mandatory arguments."
(let* ((origin (pcase references
(`(,reference) reference)
(`(,reference . ,_)
(org-element-property :parent reference))))
(org-element-parent reference))))
(suffix (org-element-property :suffix origin))
(prefix (org-element-property :prefix origin)))
(concat (and prefix

2
lisp/org/oc-bibtex.el
View file

@ -41,7 +41,7 @@
(require 'oc)
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-export-data "org-export" (data info))

186
lisp/org/oc-csl.el
View file

@ -134,11 +134,12 @@
(declare-function citeproc-render-bib "ext:citeproc")
(declare-function citeproc-hash-itemgetter-from-any "ext:citeproc")
(declare-function citeproc-add-subbib-filters "ext:citeproc")
(declare-function citeproc-style-cite-superscript-p "ext:citeproc")
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-put-property "org-element" (element property value))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-put-property "org-element-ast" (node property value))
(declare-function org-export-data "org-export" (data info))
(declare-function org-export-derived-backend-p "org-export" (backend &rest backends))
@ -184,8 +185,8 @@ looks for style files in this directory, too."
:safe #'booleanp)
(defcustom org-cite-csl-no-citelinks-backends '(ascii)
"List of export back-ends for which cite linking is disabled.
Cite linking for export back-ends derived from any of the back-ends listed here,
"List of export backends for which cite linking is disabled.
Cite linking for export backends derived from any of the backends listed here,
is also disabled."
:group 'org-cite
:package-version '(Org . "9.5")
@ -214,6 +215,112 @@ Used only when `second-field-align' is activated by the used CSL style."
:type 'string
:safe #'stringp)
(defcustom org-cite-csl-latex-label-separator "0.6em"
"Distance between citation label and bibliography item for LaTeX output.
The value is a string representing the distance in valid LaTeX units.
Used only when `second-field-align' is activated by the used CSL
style.
The indentation length in these cases is computed as the sum of
`org-cite-csl-latex-label-separator' and the maximal label width, for
example,
indentation length
<------------------------->
max. label width separator
<---------------><-------->
[Doe22] John Doe. A title...
[DoeSmithJones19] John Doe, Jane Smith and...
[SmithDoe02] Jane Smith and John Doe...
The maximal label width, in turn, is calculated as the product of
`org-cite-csl-latex-label-width-per-char' and the maximal label
length measured in characters."
:group 'org-cite
:package-version '(Org . "9.7")
:type 'string
:safe #'stringp)
(defcustom org-cite-csl-latex-label-width-per-char "0.45em"
"Character width in LaTeX units for calculating entry label widths.
Used only when `second-field-align' is activated by the used CSL
style.
See the documentation of `org-cite-csl-latex-label-separator' for
details."
:group 'org-cite
:package-version '(Org . "9.7")
:type 'string
:safe #'stringp)
;; The following was inspired by and in many details follows how
;; Pandoc's (<https://github.com/jgm/pandoc>) default LaTeX template
;; handles CSL output. Many thanks to the author, John MacFarlane!
(defcustom org-cite-csl-latex-preamble
"\\usepackage{calc}
\\newlength{\\cslhangindent}
\\setlength{\\cslhangindent}{[CSL-HANGINDENT]}
\\newlength{\\csllabelsep}
\\setlength{\\csllabelsep}{[CSL-LABELSEP]}
\\newlength{\\csllabelwidth}
\\setlength{\\csllabelwidth}{[CSL-LABELWIDTH-PER-CHAR] * [CSL-MAXLABEL-CHARS]}
\\newenvironment{cslbibliography}[2] % 1st arg. is hanging-indent, 2nd entry spacing.
{% By default, paragraphs are not indented.
\\setlength{\\parindent}{0pt}
% Hanging indent is turned on when first argument is 1.
\\ifodd #1
\\let\\oldpar\\par
\\def\\par{\\hangindent=\\cslhangindent\\oldpar}
\\fi
% Set entry spacing based on the second argument.
\\setlength{\\parskip}{\\parskip + #2\\baselineskip}
}%
{}
\\newcommand{\\cslblock}[1]{#1\\hfill\\break}
\\newcommand{\\cslleftmargin}[1]{\\parbox[t]{\\csllabelsep + \\csllabelwidth}{#1}}
\\newcommand{\\cslrightinline}[1]
{\\parbox[t]{\\linewidth - \\csllabelsep - \\csllabelwidth}{#1}\\break}
\\newcommand{\\cslindent}[1]{\\hspace{\\cslhangindent}#1}
\\newcommand{\\cslbibitem}[2]
{\\leavevmode\\vadjust pre{\\hypertarget{citeproc_bib_item_#1}{}}#2}
\\makeatletter
\\newcommand{\\cslcitation}[2]
{\\protect\\hyper@linkstart{cite}{citeproc_bib_item_#1}#2\\hyper@linkend}
\\makeatother"
"LaTeX preamble content inserted by the `csl' citation processor.
This preamble can be anything as long as it provides definitions
for the environment and commands that Citeproc's `org-latex'
formatter uses for formatting citations and bibliographies. In
particular, it has to define
- the commands \\cslblock{<text>}, \\cslleftmargin{<text>},
\\cslrightinline{<text>} and \\cslindent{<text>} for formatting
text that have, respectively, the CSL display attributes
`block', `left-margin', `right-inline' and `indent';
- the commands \\cslcitation{<item_no>}{<item_text>} and
\\cslbibitem{<item_no>}{<item_text>}, which are used to
format individual citations and bibliography items, including
hyperlinking citations to the corresponding bibliography entry
using their numerical id, which is passed as the first,
<item_no> argument;
- and the environment \\cslbibliography{<hanging-indent>}{<entry-spacing>},
in which bibliographies are wrapped; the value of the
<hanging-indent> argument is 1 if hanging indent should be
applied and 0 if not, while the <entry-spacing> argument is an
integer specifying the number of extra line-heights
required between bibliography entries in addition to normal
line spacing.
When present, the placeholders [CSL-HANGINDENT], [CSL-LABELSEP],
[CSL-LABELWIDTH-PER-CHAR] and [CSL-MAXLABEL-CHARS] are replaced,
respectively, by the contents of the customizable variables
`org-cite-csl-latex-hanging-indent', `org-cite-csl-latex-label-separator',
`org-cite-csl-latex-label-width-per-char', and the maximal label length
in the bibliography measured in characters."
:group 'org-cite
:type 'string
:package-version '(Org . "9.7"))
;;; Internal variables
(defconst org-cite-csl--etc-dir
@ -277,13 +384,17 @@ If nil then the Chicago author-date style is used as a fallback.")
("paragraph" . "paragraph")
("para." . "paragraph")
("paras." . "paragraph")
("\\P" . "paragraph")
("" . "paragraph")
("\\P\\P" . "paragraph")
("¶¶" . "paragraph")
("part" . "part")
("pt." . "part")
("pts." . "part")
("§" . "section")
("\\S" . "section")
("§§" . "section")
("\\S\\S" . "section")
("section" . "section")
("sec." . "section")
("secs." . "section")
@ -312,10 +423,6 @@ Label is in match group 1.")
;;; Internal functions
(defun org-cite-csl--barf-without-citeproc ()
"Raise an error if Citeproc library is not loaded."
(unless (featurep 'citeproc)
(error "Citeproc library is not loaded")))
(defun org-cite-csl--note-style-p (info)
"Non-nil when bibliography style implies wrapping citations in footnotes.
@ -324,6 +431,13 @@ INFO is the export state, as a property list."
(citeproc-proc-style
(org-cite-csl--processor info))))
(defun org-cite-csl--style-cite-superscript-p (info)
"Non-nil when bibliography style produces citations in superscript.
INFO is the export state, as a property list."
(citeproc-style-cite-superscript-p
(citeproc-proc-style
(org-cite-csl--processor info))))
(defun org-cite-csl--nocite-p (citation info)
"Non-nil when CITATION object's style is nocite.
INFO is the export state, as a property list."
@ -332,8 +446,8 @@ INFO is the export state, as a property list."
(defun org-cite-csl--create-structure-params (citation info)
"Return citeproc structure creation params for CITATION object.
STYLE is the citation style, as a string or nil. INFO is the export state, as
a property list."
STYLE is the citation style, as a string or nil. INFO is the export
state, as a property list."
(let ((style (org-cite-citation-style citation info)))
(pcase style
;; "author" style.
@ -393,7 +507,8 @@ a property list."
(_ (error "Invalid style: %S" style)))))
(defun org-cite-csl--no-citelinks-p (info)
"Non-nil when export BACKEND should not create cite-reference links."
"Non-nil when export backend should not create cite-reference links.
INFO is the info channel plist."
(or (not org-cite-csl-link-cites)
(and org-cite-csl-no-citelinks-backends
(apply #'org-export-derived-backend-p
@ -413,7 +528,7 @@ corresponding to one of the output formats supported by Citeproc: `html',
(let ((backend (plist-get info :back-end)))
(cond
((org-export-derived-backend-p backend 'html) 'html)
((org-export-derived-backend-p backend 'latex) 'latex)
((org-export-derived-backend-p backend 'latex) 'org-latex)
(t 'org))))
(defun org-cite-csl--style-file (info)
@ -569,6 +684,9 @@ INFO is the export state, as a property list."
(when (and (not footnote) (org-cite-csl--note-style-p info))
(org-cite-adjust-note citation info)
(setq footnote (org-cite-wrap-citation citation info)))
;; Remove white space before CITATION when it is in superscript.
(when (org-cite-csl--style-cite-superscript-p info)
(org-cite--set-previous-post-blank citation 0 info))
;; Return structure.
(apply #'citeproc-citation-create
`(:note-index
@ -670,12 +788,27 @@ value is the bibliography as rendered by Citeproc."
(plist-put info :cite-citeproc-rendered-bibliographies result)
result)))))
(defun org-cite-csl--generate-latex-preamble (info)
"Generate the CSL-related part of the LaTeX preamble.
INFO is the export state, as a property list."
(let* ((parameters (cadr (org-cite-csl--rendered-bibliographies info)))
(max-offset (cdr (assq 'max-offset parameters)))
(result org-cite-csl-latex-preamble))
(map-do (lambda (placeholder replacement)
(when (string-match placeholder result)
(setq result (replace-match replacement t t result))))
`("\\[CSL-HANGINDENT\\]" ,org-cite-csl-latex-hanging-indent
"\\[CSL-LABELSEP\\]" ,org-cite-csl-latex-label-separator
"\\[CSL-LABELWIDTH-PER-CHAR\\]" ,org-cite-csl-latex-label-width-per-char
"\\[CSL-MAXLABEL-CHARS\\]" ,(number-to-string max-offset)))
result))
;;; Export capability
(defun org-cite-csl-render-citation (citation _style _backend info)
"Export CITATION object.
INFO is the export state, as a property list."
(org-cite-csl--barf-without-citeproc)
(org-require-package 'citeproc)
(let ((output (cdr (assq citation (org-cite-csl--rendered-citations info)))))
(if (not (eq 'org (org-cite-csl--output-format info)))
output
@ -686,10 +819,10 @@ INFO is the export state, as a property list."
(defun org-cite-csl-render-bibliography (_keys _files _style props _backend info)
"Export bibliography.
INFO is the export state, as a property list."
(org-cite-csl--barf-without-citeproc)
(org-require-package 'citeproc)
(pcase-let* ((format (org-cite-csl--output-format info))
(`(,outputs ,parameters) (org-cite-csl--rendered-bibliographies info))
(output (cdr (assoc props outputs))))
(`(,outputs ,parameters) (org-cite-csl--rendered-bibliographies info))
(output (cdr (assoc props outputs))))
(pcase format
('html
(concat
@ -714,12 +847,7 @@ INFO is the export state, as a property list."
org-cite-csl-html-hanging-indent
org-cite-csl-html-hanging-indent))
output))
('latex
(if (cdr (assq 'hanging-indent parameters))
(format "\\begin{hangparas}{%s}{1}\n%s\n\\end{hangparas}"
org-cite-csl-latex-hanging-indent
output)
output))
('org-latex output)
(_
;; Parse Org output to re-export it during the regular export
;; process.
@ -729,19 +857,15 @@ INFO is the export state, as a property list."
"Add \"hanging\" package if missing from LaTeX output.
OUTPUT is the export document, as a string. INFO is the export state, as a
property list."
(org-cite-csl--barf-without-citeproc)
(if (not (eq 'latex (org-cite-csl--output-format info)))
(org-require-package 'citeproc)
(if (not (eq 'org-latex (org-cite-csl--output-format info)))
output
(with-temp-buffer
(save-excursion (insert output))
(when (search-forward "\\begin{document}" nil t)
(goto-char (match-beginning 0))
;; Ensure that \citeprocitem is defined for citeproc-el.
(insert "\\makeatletter\n\\newcommand{\\citeprocitem}[2]{\\hyper@linkstart{cite}{citeproc_bib_item_#1}#2\\hyper@linkend}\n\\makeatother\n\n")
;; Ensure there is a \usepackage{hanging} somewhere or add one.
(let ((re (rx "\\usepackage" (opt "[" (*? nonl) "]") "{hanging}")))
(unless (re-search-backward re nil t)
(insert "\\usepackage[notquote]{hanging}\n"))))
(goto-char (match-beginning 0))
;; Insert the CSL-specific parts of the LaTeX preamble.
(insert (org-cite-csl--generate-latex-preamble info)))
(buffer-string))))

23
lisp/org/oc-natbib.el
View file

@ -48,7 +48,7 @@
(require 'oc)
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-export-data "org-export" (data info))
@ -77,6 +77,15 @@ If \"natbib\" package is already required in the document, e.g., through
(const :tag "redefine \\thebibliography to issue \\section* instead of \\chapter*" sectionbib)
(const :tag "keep all the authors' names in a citation on one line" nonamebreak)))
(defcustom org-cite-natbib-bibliography-style 'unsrtnat
"Default bibliography style."
:group 'org-cite
:package-version '(Org . "9.7")
:type
'(choice
(const unsrtnat)
(symbol :tag "Other")))
;;; Internal functions
(defun org-cite-natbib--style-to-command (style)
@ -143,11 +152,13 @@ CITATION is the citation object. INFO is the export state, as a property list."
"Print references from bibliography FILES.
FILES is a list of absolute file names. STYLE is the bibliography style, as
a string or nil."
(concat (and style (format "\\bibliographystyle{%s}\n" style))
(format "\\bibliography{%s}"
(mapconcat #'file-name-sans-extension
files
","))))
(concat
(format "\\bibliographystyle{%s}\n"
(or style org-cite-natbib-bibliography-style))
(format "\\bibliography{%s}"
(mapconcat #'file-name-sans-extension
files
","))))
(defun org-cite-natbib-export-citation (citation style _ info)
"Export CITATION object.

222
lisp/org/oc.el
View file

@ -46,8 +46,8 @@
;; The "export" capability is slightly more involved as one need to
;; select the processor providing it, but may also provide a default
;; style for citations and bibliography. Also, the choice of an
;; export processor may depend of the current export back-end. The
;; association between export back-ends and triplets of parameters can
;; export processor may depend of the current export backend. The
;; association between export backends and triplets of parameters can
;; be set in `org-cite-export-processors' variable, or in a document,
;; through the "cite_export" keyword.
@ -71,25 +71,33 @@
(declare-function org-at-heading-p "org" (&optional _))
(declare-function org-collect-keywords "org" (keywords &optional unique directory))
(declare-function org-element-adopt-elements "org-element" (parent &rest children))
(declare-function org-element-adopt "org-element-ast" (parent &rest children))
(declare-function org-element-citation-parser "org-element" ())
(declare-function org-element-citation-reference-parser "org-element" ())
(declare-function org-element-class "org-element" (datum &optional parent))
(declare-function org-element-contents "org-element" (element))
(declare-function org-element-create "org-element" (type &optional props &rest children))
(declare-function org-element-extract-element "org-element" (element))
(declare-function org-element-insert-before "org-element" (element location))
(declare-function org-element-lineage "org-element" (datum &optional types with-self))
(declare-function org-element-contents "org-element-ast" (node))
(declare-function org-element-create "org-element-ast" (type &optional props &rest children))
(declare-function org-element-extract "org-element-ast" (node))
(declare-function org-element-insert-before "org-element-ast" (node location))
(declare-function org-element-lineage "org-element-ast" (datum &optional types with-self))
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-normalize-string "org-element" (s))
(declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only))
(declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only keep-deferred))
(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-put-property "org-element" (element property value))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element-post-blank "org-element" (node))
(declare-function org-element-contents-begin "org-element" (node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-parent "org-element-ast" (node))
(declare-function org-element-put-property "org-element-ast" (node property value))
(declare-function org-element-restriction "org-element" (element))
(declare-function org-element-set-element "org-element" (old new))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-set "org-element-ast" (old new))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-export-derived-backend-p "org-export" (backend &rest backends))
(declare-function org-export-get-next-element "org-export" (blob info &optional n))
@ -143,12 +151,12 @@ File names must be absolute."
When nil, citations and bibliography are not exported.
When non-nil, the value is an association list between export back-ends and
When non-nil, the value is an association list between export backends and
citation export processors:
(BACK-END . PROCESSOR)
(BACKEND . PROCESSOR)
where BACK-END is the name of an export back-end or t, and PROCESSOR is a
where BACKEND is the name of an export backend or t, and PROCESSOR is a
triplet following the pattern
(NAME BIBLIOGRAPHY-STYLE CITATION-STYLE)
@ -160,7 +168,7 @@ exporting a citation), as a string or nil. Both BIBLIOGRAPHY-STYLE and
CITATION-STYLE are optional. NAME is mandatory.
The export process selects the citation processor associated to the current
export back-end, or the most specific back-end the current one is derived from,
export backend, or the most specific backend the current one is derived from,
or, if all are inadequate, to the processor associated to t. For example, with
the following value
@ -168,9 +176,9 @@ the following value
(latex biblatex)
(t csl))
exporting with `beamer' or any back-end derived from it will use `natbib',
whereas exporting with `latex' or any back-end derived from it but different
from `beamer' will use `biblatex' processor. Any other back-end, such as
exporting with `beamer' or any backend derived from it will use `natbib',
whereas exporting with `latex' or any backend derived from it but different
from `beamer' will use `biblatex' processor. Any other backend, such as
`html', will use `csl' processor.
CITATION-STYLE is overridden by adding a style to any citation object. A nil
@ -187,7 +195,7 @@ or
#+CITE_EXPORT: basic
In that case, `basic' processor is used on every export, independently on the
back-end."
backend."
:group 'org-cite
:package-version '(Org . "9.5")
:type '(choice (const :tag "No export" nil)
@ -345,7 +353,7 @@ optional keys can be set:
arguments: the list of citation keys used in the document, as
strings, a list of bibliography files, the style, as a string
or nil, the local properties, as a property list, the export
back-end, as a symbol, and the communication channel, as a
backend, as a symbol, and the communication channel, as a
property list.
It is called at each \"print_bibliography\" keyword in the
@ -358,7 +366,7 @@ optional keys can be set:
Function rendering citations. It is called with four
arguments: a citation object, the style, as a pair, the
export back-end, as a symbol, and the communication channel,
export backend, as a symbol, and the communication channel,
as a property list.
It is called on each citation object in the parse tree. It
@ -373,7 +381,7 @@ optional keys can be set:
six arguments: the output, as a string, a list of citation
keys used in the document, a list of bibliography files, the
expected bibliography style, as a string or nil, the export
back-end, as a symbol, and the communication channel, as a
backend, as a symbol, and the communication channel, as a
property list.
It must return a string, which will become the final output
@ -468,11 +476,11 @@ PROCESSOR is the name of a cite processor, as a symbol. CAPABILITY is
"Set `:post-blank' property from element or object before DATUM to BLANKS.
DATUM is an element or object. BLANKS is an integer. DATUM is modified
by side-effect."
(if (not (eq 'plain-text (org-element-type datum)))
(if (not (org-element-type-p datum 'plain-text))
(org-element-put-property datum :post-blank blanks)
;; Remove any blank from string before DATUM so it is exported
;; with exactly BLANKS white spaces.
(org-element-set-element
(org-element-set
datum
(replace-regexp-in-string
"[ \t\n]*\\'" (make-string blanks ?\s) datum))))
@ -492,11 +500,11 @@ S is split at beginning of match group N upon matching REGEXP against it.
This function assumes S precedes CITATION."
;; When extracting the citation, remove white spaces before it, but
;; preserve those after it.
(let ((post-blank (org-element-property :post-blank citation)))
(let ((post-blank (org-element-post-blank citation)))
(when (and post-blank (> post-blank 0))
(org-element-insert-before (make-string post-blank ?\s) citation)))
(org-element-insert-before
(org-element-put-property (org-element-extract-element citation)
(org-element-put-property (org-element-extract citation)
:post-blank 0)
s)
(string-match regexp s)
@ -510,21 +518,21 @@ This function assumes S precedes CITATION."
(substring s split))))
(when (org-string-nw-p first-part)
(org-element-insert-before first-part citation))
(org-element-set-element s last-part)))
(org-element-set s last-part)))
(defun org-cite--move-punct-before (punct citation s info)
"Move punctuation PUNCT before CITATION object.
String S contains PUNCT. INFO is the export state, as a property list.
The function assumes S follows CITATION. Parse tree is modified by side-effect."
(if (equal s punct)
(org-element-extract-element s) ;it would be empty anyway
(org-element-set-element s (substring s (length punct))))
(org-element-extract s) ;it would be empty anyway
(org-element-set s (substring s (length punct))))
;; Remove blanks before citation.
(org-cite--set-previous-post-blank citation 0 info)
(org-element-insert-before
;; Blanks between citation and punct are now before punct and
;; citation.
(concat (make-string (or (org-element-property :post-blank citation) 0) ?\s)
(concat (make-string (or (org-element-post-blank citation) 0) ?\s)
punct)
citation))
@ -602,7 +610,18 @@ to (adaptive outside after)."
(append (mapcar (lambda (value)
(pcase value
(`(,f . ,d)
(expand-file-name (org-strip-quotes f) d))))
(setq f (org-strip-quotes f))
(if (or (file-name-absolute-p f)
(file-remote-p f)
(equal d default-directory))
;; Keep absolute paths, remote paths, and
;; local relative paths.
f
;; Adjust relative bibliography path for
;; #+SETUP files located in other directory.
;; Also, see `org-export--update-included-link'.
(file-relative-name
(expand-file-name f d) default-directory)))))
(pcase (org-collect-keywords
'("BIBLIOGRAPHY") nil '("BIBLIOGRAPHY"))
(`(("BIBLIOGRAPHY" . ,pairs)) pairs)))
@ -619,12 +638,12 @@ or from the current buffer."
(let ((contents (org-element-contents citation)))
(cond
((null contents)
(org-with-point-at (org-element-property :contents-begin citation)
(narrow-to-region (point) (org-element-property :contents-end citation))
(org-with-point-at (org-element-contents-begin citation)
(narrow-to-region (point) (org-element-contents-end citation))
(let ((references nil))
(while (not (eobp))
(let ((reference (org-element-citation-reference-parser)))
(goto-char (org-element-property :end reference))
(goto-char (org-element-end reference))
(push (if keys-only
(org-element-property :key reference)
reference)
@ -636,8 +655,8 @@ or from the current buffer."
(defun org-cite-boundaries (citation)
"Return the beginning and end strict position of CITATION.
Returns a (BEG . END) pair."
(let ((beg (org-element-property :begin citation))
(end (org-with-point-at (org-element-property :end citation)
(let ((beg (org-element-begin citation))
(end (org-with-point-at (org-element-end citation)
(skip-chars-backward " \t")
(point))))
(cons beg end)))
@ -646,15 +665,15 @@ Returns a (BEG . END) pair."
"Return citation REFERENCE's key boundaries as buffer positions.
The function returns a pair (START . END) where START and END denote positions
in the current buffer. Positions include leading \"@\" character."
(org-with-point-at (org-element-property :begin reference)
(let ((end (org-element-property :end reference)))
(org-with-point-at (org-element-begin reference)
(let ((end (org-element-end reference)))
(re-search-forward org-element-citation-key-re end t)
(cons (match-beginning 0) (match-end 0)))))
(defun org-cite-main-affixes (citation)
"Return main affixes for CITATION object.
Some export back-ends only support a single pair of affixes per
Some export backends only support a single pair of affixes per
citation, even if it contains multiple keys. This function
decides what affixes are the most appropriate.
@ -730,7 +749,7 @@ When removing the last reference, also remove the whole citation."
(org-with-point-at begin
(skip-chars-backward " \t")
(point)))
(pos-after-blank (org-element-property :end datum))
(pos-after-blank (org-element-end datum))
(first-on-line?
(= pos-before-blank (line-beginning-position)))
(last-on-line?
@ -753,22 +772,22 @@ When removing the last reference, also remove the whole citation."
(when (= pos-after-blank end)
(org-with-point-at pos-before-blank (insert " ")))))))
('citation-reference
(let* ((citation (org-element-property :parent datum))
(let* ((citation (org-element-parent datum))
(references (org-cite-get-references citation))
(begin (org-element-property :begin datum))
(end (org-element-property :end datum)))
(begin (org-element-begin datum))
(end (org-element-end datum)))
(cond
;; Single reference.
((= 1 (length references))
(org-cite-delete-citation citation))
;; First reference, no prefix.
((and (= begin (org-element-property :contents-begin citation))
((and (= begin (org-element-contents-begin citation))
(not (org-element-property :prefix citation)))
(org-with-point-at (org-element-property :begin datum)
(org-with-point-at (org-element-begin datum)
(skip-chars-backward " \t")
(delete-region (point) end)))
;; Last reference, no suffix.
((and (= end (org-element-property :contents-end citation))
((and (= end (org-element-contents-end citation))
(not (org-element-property :suffix citation)))
(delete-region (1- begin) (1- (cdr (org-cite-boundaries citation)))))
;; Somewhere in-between.
@ -838,6 +857,11 @@ tokens. Spurious spaces are ignored."
s))
(nreverse result))))
(defun org-cite-processor (info)
"Return expected citation/bibliography processor.
INFO is a plist used as a communication channel."
(car (plist-get info :cite-export)))
(defun org-cite-bibliography-style (info)
"Return expected bibliography style.
INFO is a plist used as a communication channel."
@ -937,11 +961,12 @@ the sole contents of the footnote, e.g., after calling `org-cite-wrap-citation'.
When non-nil, the return value if the footnote container."
(let ((footnote
(org-element-lineage citation
'(footnote-definition footnote-reference))))
(org-element-lineage
citation
'(footnote-definition footnote-reference))))
(and footnote
(or (not strict)
(equal (org-element-contents (org-element-property :parent citation))
(equal (org-element-contents (org-element-parent citation))
(list citation)))
;; Return value.
footnote)))
@ -959,15 +984,15 @@ Return newly created footnote object."
(list 'footnote-reference
(list :label nil
:type 'inline
:contents-begin (org-element-property :begin citation)
:contents-end (org-element-property :end citation)
:post-blank (org-element-property :post-blank citation)))))
:contents-begin (org-element-begin citation)
:contents-end (org-element-end citation)
:post-blank (org-element-post-blank citation)))))
;; Remove any white space before citation.
(org-cite--set-previous-post-blank citation 0 info)
;; Footnote swallows citation.
(org-element-insert-before footnote citation)
(org-element-adopt-elements footnote
(org-element-extract-element citation))))
(org-element-adopt footnote
(org-element-extract citation))))
(defun org-cite-adjust-note (citation info &optional rule punct)
"Adjust note number location for CITATION object, and punctuation around it.
@ -1046,8 +1071,8 @@ the same object, call `org-cite-adjust-note' first."
;; as an argument is not available.
(rx-to-string `(seq string-start ,final-punct) t)
"" next)))
(org-element-set-element previous new-prev)
(org-element-set-element next new-next)
(org-element-set previous new-prev)
(org-element-set next new-next)
(setq previous new-prev)
(setq next new-next)
(setq punct final-punct)
@ -1066,15 +1091,15 @@ the same object, call `org-cite-adjust-note' first."
(replace-regexp-in-string
previous-punct-re "" previous nil nil 1))
(new-next (if (stringp next) (concat punct next) punct)))
(org-element-set-element previous new-prev)
(org-element-set previous new-prev)
(cond
((stringp next)
(org-element-set-element next new-next))
(org-element-set next new-next))
(next
(org-element-insert-before new-next next))
(t
(org-element-adopt-elements
(org-element-property :parent citation)
(org-element-adopt
(org-element-parent citation)
new-next)))
(setq previous new-prev)
(setq next new-next)
@ -1141,7 +1166,7 @@ raises an error if S contains a headline."
(insert s)
(pcase (org-element-contents (org-element-parse-buffer))
('nil nil)
(`(,(and section (guard (eq 'section (org-element-type section)))))
(`(,(and section (guard (org-element-type-p section 'section))))
(org-element-contents section))
(_
(error "Headlines cannot replace a keyword")))))
@ -1201,14 +1226,23 @@ and must return either a string, an object, or a secondary string."
(org-cite-concat result separator (funcall function datum))))
result)))
(defun org-cite-capitalize (str)
"Capitalize string of raw string object STR."
(cond
((stringp str) (capitalize str))
((org-element-type-p str 'raw)
(org-export-raw-string
(capitalize (mapconcat #'identity (org-element-contents str) ""))))
(t (error "%S must be either a string or raw string object" str))))
;;; Internal interface with fontification (activate capability)
(defun org-cite-fontify-default (cite)
"Fontify CITE with `org-cite' and `org-cite-key' faces.
CITE is a citation object. The function applies `org-cite' face
on the whole citation, and `org-cite-key' face on each key."
(let ((beg (org-element-property :begin cite))
(end (org-with-point-at (org-element-property :end cite)
(let ((beg (org-element-begin cite))
(end (org-with-point-at (org-element-end cite)
(skip-chars-backward " \t")
(point))))
(add-text-properties beg end '(font-lock-multiline t))
@ -1237,7 +1271,7 @@ from the processor set in `org-cite-activate-processor'."
(save-match-data (funcall activate cite))
;; Move after cite object and make sure to return
;; a non-nil value.
(goto-char (org-element-property :end cite)))))))
(goto-char (org-element-end cite)))))))
;;; Internal interface with Org Export library (export capability)
@ -1274,12 +1308,12 @@ side-effect."
;; Value is an alist. It must come from
;; `org-cite-export-processors' variable. Find the most
;; appropriate processor according to current export
;; back-end.
;; backend.
((and (pred consp) alist)
(let* ((backend (plist-get info :back-end))
(candidates
;; Limit candidates to processors associated to
;; back-ends derived from or equal to the current
;; backends derived from or equal to the current
;; one.
(sort (seq-filter
(pcase-lambda (`(,key . ,_))
@ -1331,7 +1365,7 @@ selected citation processor."
(defun org-cite-export-bibliography (keyword _ info)
"Return bibliography associated to \"print_bibliography\" KEYWORD.
BACKEND is the export back-end, as a symbol. INFO is a plist
BACKEND is the export backend, as a symbol. INFO is a plist
used as a communication channel."
(pcase (plist-get info :cite-export)
('nil nil)
@ -1355,7 +1389,7 @@ INFO is the communication channel, as a plist. Parse tree is modified
by side-effect."
(dolist (cite (org-cite-list-citations info))
(let ((replacement (org-cite-export-citation cite nil info))
(blanks (or (org-element-property :post-blank cite) 0)))
(blanks (or (org-element-post-blank cite) 0)))
(if (null replacement)
;; Before removing the citation, transfer its `:post-blank'
;; property to the object before, if any.
@ -1389,7 +1423,7 @@ by side-effect."
(_
(error "Invalid return value from citation export processor: %S"
replacement))))
(org-element-extract-element cite))))
(org-element-extract cite))))
(defun org-cite-process-bibliography (info)
"Replace all \"print_bibliography\" keywords in the parse tree.
@ -1400,18 +1434,18 @@ by side effect."
(lambda (keyword)
(when (equal "PRINT_BIBLIOGRAPHY" (org-element-property :key keyword))
(let ((replacement (org-cite-export-bibliography keyword nil info))
(blanks (or (org-element-property :post-blank keyword) 0)))
(blanks (or (org-element-post-blank keyword) 0)))
(pcase replacement
;; Before removing the citation, transfer its
;; `:post-blank' property to the element before, if any.
('nil
(org-cite--set-previous-post-blank keyword blanks info)
(org-element-extract-element keyword))
(org-element-extract keyword))
;; Handle `:post-blank' before replacing keyword with string.
((pred stringp)
(let ((output (concat (org-element-normalize-string replacement)
(make-string blanks ?\n))))
(org-element-set-element keyword (org-export-raw-string output))))
(org-element-set keyword (org-export-raw-string output))))
;; List of elements: splice contents before keyword and
;; remove the latter. Transfer `:post-blank' to last
;; element.
@ -1421,11 +1455,11 @@ by side effect."
(setq last datum)
(org-element-insert-before datum keyword))
(org-cite--set-post-blank last blanks)
(org-element-extract-element keyword)))
(org-element-extract keyword)))
;; Single element: replace the keyword.
(`(,(pred symbolp) . ,_)
(org-cite--set-post-blank replacement blanks)
(org-element-set-element keyword replacement))
(org-element-set keyword replacement))
(_
(error "Invalid return value from citation export processor: %S"
replacement))))))
@ -1481,7 +1515,7 @@ CONTEXT is the element or object at point, as returned by `org-element-context'.
;;
;; XXX: Inserting citation in a secondary value is not allowed
;; yet. Is it useful?
((let ((post (org-element-property :post-affiliated context)))
((let ((post (org-element-post-affiliated context)))
(and post (< (point) post)))
(let ((case-fold-search t))
(looking-back
@ -1497,14 +1531,14 @@ CONTEXT is the element or object at point, as returned by `org-element-context'.
((memq type '(nil paragraph)))
;; So are contents of verse blocks.
((eq type 'verse-block)
(and (>= (point) (org-element-property :contents-begin context))
(< (point) (org-element-property :contents-end context))))
(and (>= (point) (org-element-contents-begin context))
(< (point) (org-element-contents-end context))))
;; In an headline or inlinetask, point must be either on the
;; heading itself or on the blank lines below.
((memq type '(headline inlinetask))
(or (not (org-at-heading-p))
(and (save-excursion
(beginning-of-line)
(forward-line 0)
(and (let ((case-fold-search t))
(not (looking-at-p "\\*+ END[ \t]*$")))
(let ((case-fold-search nil))
@ -1523,43 +1557,43 @@ CONTEXT is the element or object at point, as returned by `org-element-context'.
;; White spaces after an object or blank lines after an element
;; are OK.
((>= (point)
(save-excursion (goto-char (org-element-property :end context))
(skip-chars-backward " \r\t\n")
(if (eq (org-element-class context) 'object) (point)
(line-beginning-position 2)))))
(save-excursion (goto-char (org-element-end context))
(skip-chars-backward " \r\t\n")
(if (eq (org-element-class context) 'object) (point)
(line-beginning-position 2)))))
;; At the beginning of a footnote definition, right after the
;; label, is OK.
((eq type 'footnote-definition) (looking-at (rx space)))
;; At the start of a list item is fine, as long as the bullet is
;; unaffected.
((eq type 'item)
(> (point) (+ (org-element-property :begin context)
(> (point) (+ (org-element-begin context)
(org-current-text-indentation)
(if (org-element-property :checkbox context)
5 1))))
;; Other elements are invalid.
((eq (org-element-class context) 'element) nil)
;; Just before object is fine.
((= (point) (org-element-property :begin context)))
((= (point) (org-element-begin context)))
;; Within recursive object too, but not in a link.
((eq type 'link) nil)
((eq type 'table-cell)
;; :contents-begin is not reliable on empty cells, so special
;; case it.
(<= (save-excursion (skip-chars-backward " \t") (point))
(org-element-property :contents-end context)))
((let ((cbeg (org-element-property :contents-begin context))
(cend (org-element-property :contents-end context)))
(org-element-contents-end context)))
((let ((cbeg (org-element-contents-begin context))
(cend (org-element-contents-end context)))
(and cbeg (>= (point) cbeg) (<= (point) cend)))))))
(defun org-cite--insert-string-before (string reference)
"Insert STRING before citation REFERENCE object."
(org-with-point-at (org-element-property :begin reference)
(org-with-point-at (org-element-begin reference)
(insert string ";")))
(defun org-cite--insert-string-after (string reference)
"Insert STRING after citation REFERENCE object."
(org-with-point-at (org-element-property :end reference)
(org-with-point-at (org-element-end reference)
;; Make sure to move forward when we're inserting at point, so the
;; insertion can happen multiple times.
(if (char-equal ?\; (char-before))
@ -1630,7 +1664,7 @@ More specifically,
;; action depends on the point.
(if arg
(org-cite-delete-citation context)
(let* ((begin (org-element-property :begin context))
(let* ((begin (org-element-begin context))
(style-end (1- (org-with-point-at begin (search-forward ":")))))
(if (>= style-end (point))
;; On style part, edit the style.
@ -1644,7 +1678,7 @@ More specifically,
;; point.
(let* ((references (org-cite-get-references context))
(key (concat "@" (funcall select-key nil))))
(if (< (point) (org-element-property :contents-begin context))
(if (< (point) (org-element-contents-begin context))
(org-cite--insert-string-before key (car references))
(org-cite--insert-string-after key (org-last references))))))))
;; On a citation reference. If ARG is not nil, remove the
@ -1699,7 +1733,7 @@ ARG is the prefix argument received when calling interactively the function."
(let ((context (org-element-context))
(insert (org-cite-processor-insert (org-cite-get-processor name))))
(cond
((memq (org-element-type context) '(citation citation-reference))
((org-element-type-p context '(citation citation-reference))
(funcall insert context arg))
((org-cite--allowed-p context)
(funcall insert nil arg))

10
lisp/org/ol-bbdb.el
View file

@ -226,7 +226,7 @@ date year)."
;;; Implementation
(defun org-bbdb-store-link ()
(defun org-bbdb-store-link (&optional _interactive?)
"Store a link to a BBDB database entry."
(when (eq major-mode 'bbdb-mode)
;; This is BBDB, we make this link!
@ -255,7 +255,7 @@ italicized, in all other cases it is left unchanged."
(defun org-bbdb-open (name _)
"Follow a BBDB link to NAME."
(require 'bbdb-com)
(org-require-package 'bbdb-com "bbdb")
(let ((inhibit-redisplay (not debug-on-error)))
(if (fboundp 'bbdb-name)
(org-bbdb-open-old name)
@ -369,7 +369,7 @@ This is used by Org to re-create the anniversary hash table."
"Extract anniversaries from BBDB for display in the agenda.
When called programmatically, this function expects the `date'
variable to be globally bound."
(require 'bbdb)
(org-require-package 'bbdb)
(require 'diary-lib)
(unless (hash-table-p org-bbdb-anniv-hash)
(setq org-bbdb-anniv-hash
@ -500,7 +500,7 @@ must be positive"))
(defun org-bbdb-complete-link ()
"Read a bbdb link with name completion."
(require 'bbdb-com)
(org-require-package 'bbdb-com "bbdb")
(let ((rec (bbdb-completing-read-record "Name: ")))
(concat "bbdb:"
(bbdb-record-name (if (listp rec)
@ -509,7 +509,7 @@ must be positive"))
(defun org-bbdb-anniv-export-ical ()
"Extract anniversaries from BBDB and convert them to icalendar format."
(require 'bbdb)
(org-require-package 'bbdb)
(require 'diary-lib)
(unless (hash-table-p org-bbdb-anniv-hash)
(setq org-bbdb-anniv-hash

61
lisp/org/ol-bibtex.el
View file

@ -266,7 +266,7 @@ a missing title field."
:type 'boolean)
(defcustom org-bibtex-headline-format-function
(lambda (entry) (cdr (assq :title entry)))
#'org-bibtex-headline-format-default
"Function returning the headline text for `org-bibtex-write'.
It should take a single argument, the bibtex entry (an alist as
returned by `org-bibtex-read'). The default value simply returns
@ -507,7 +507,7 @@ ARG, when non-nil, is a universal prefix argument. See
`org-open-file' for details."
(org-link-open-as-file path arg))
(defun org-bibtex-store-link ()
(defun org-bibtex-store-link (&optional _interactive?)
"Store a link to a BibTeX entry."
(when (eq major-mode 'bibtex-mode)
(let* ((search (org-create-file-search-in-bibtex))
@ -636,22 +636,27 @@ With prefix argument OPTIONAL also prompt for optional fields."
With prefix argument OPTIONAL also prompt for optional fields."
(interactive) (org-map-entries (lambda () (org-bibtex-check optional))))
(defun org-bibtex-create (&optional arg nonew)
(defun org-bibtex-headline-format-default (entry)
"Return headline text according to ENTRY title."
(cdr (assq :title entry)))
(defun org-bibtex-create (&optional arg update-heading)
"Create a new entry at the given level.
With a prefix arg, query for optional fields as well.
If nonew is t, add data to the headline of the entry at point."
With a prefix ARG, query for optional fields as well.
If UPDATE-HEADING is non-nil, add data to the headline of the entry at
point."
(interactive "P")
(let* ((type (completing-read
"Type: " (mapcar (lambda (type)
(substring (symbol-name (car type)) 1))
org-bibtex-types)
nil nil (when nonew
(org-bibtex-get org-bibtex-type-property-name))))
nil nil (when update-heading
(org-bibtex-get org-bibtex-type-property-name))))
(type (if (keywordp type) type (intern (concat ":" type))))
(org-bibtex-treat-headline-as-title (if nonew nil t)))
(org-bibtex-treat-headline-as-title (if update-heading nil t)))
(unless (assoc type org-bibtex-types)
(error "Type:%s is not known" type))
(if nonew
(if update-heading
(org-back-to-heading)
(org-insert-heading)
(let ((title (org-bibtex-ask :title)))
@ -718,29 +723,32 @@ Return the number of saved entries."
(interactive "fFile: ")
(org-bibtex-read-buffer (find-file-noselect file 'nowarn 'rawfile)))
(defun org-bibtex-write (&optional noindent)
(defun org-bibtex-write (&optional noindent update-heading)
"Insert a heading built from the first element of `org-bibtex-entries'.
When optional argument NOINDENT is non-nil, do not indent the properties
drawer."
drawer. If UPDATE-HEADING is non-nil, add data to the headline of the
entry at point."
(interactive)
(unless org-bibtex-entries
(error "No entries in `org-bibtex-entries'"))
(let* ((entry (pop org-bibtex-entries))
(org-special-properties nil) ; avoids errors with `org-entry-put'
(val (lambda (field) (cdr (assoc field entry))))
(togtag (lambda (tag) (org-toggle-tag tag 'on))))
(org-insert-heading)
(insert (funcall org-bibtex-headline-format-function entry))
(insert "\n:PROPERTIES:\n")
(org-bibtex-put "TITLE" (funcall val :title) 'insert)
(togtag (lambda (tag) (org-toggle-tag tag 'on)))
(insert-raw (not update-heading)))
(unless update-heading
(org-insert-heading)
(insert (funcall org-bibtex-headline-format-function entry))
(insert "\n:PROPERTIES:\n"))
(org-bibtex-put "TITLE" (funcall val :title) insert-raw)
(org-bibtex-put org-bibtex-type-property-name
(downcase (funcall val :type))
'insert)
insert-raw)
(dolist (pair entry)
(pcase (car pair)
(:title nil)
(:type nil)
(:key (org-bibtex-put org-bibtex-key-property (cdr pair) 'insert))
(:key (org-bibtex-put org-bibtex-key-property (cdr pair) insert-raw))
(:keywords (if org-bibtex-tags-are-keywords
(dolist (kw (split-string (cdr pair) ", *"))
(funcall
@ -748,25 +756,28 @@ drawer."
(replace-regexp-in-string
"[^[:alnum:]_@#%]" ""
(replace-regexp-in-string "[ \t]+" "_" kw))))
(org-bibtex-put (car pair) (cdr pair) 'insert)))
(_ (org-bibtex-put (car pair) (cdr pair) 'insert))))
(insert ":END:\n")
(org-bibtex-put (car pair) (cdr pair) insert-raw)))
(_ (org-bibtex-put (car pair) (cdr pair) insert-raw))))
(unless update-heading
(insert ":END:\n"))
(mapc togtag org-bibtex-tags)
(unless noindent
(org-indent-region
(save-excursion (org-back-to-heading t) (point))
(point)))))
(defun org-bibtex-yank ()
"If kill ring holds a bibtex entry yank it as an Org headline."
(interactive)
(defun org-bibtex-yank (&optional update-heading)
"If kill ring holds a bibtex entry yank it as an Org headline.
When called with non-nil prefix argument UPDATE-HEADING, add data to the
headline of the entry at point."
(interactive "P")
(let (entry)
(with-temp-buffer
(yank 1)
(bibtex-mode)
(setf entry (org-bibtex-read)))
(if entry
(org-bibtex-write)
(org-bibtex-write nil update-heading)
(error "Yanked text does not appear to contain a BibTeX entry"))))
(defun org-bibtex-import-from-file (file)

13
lisp/org/ol-docview.el
View file

@ -57,20 +57,21 @@
:export #'org-docview-export
:store #'org-docview-store-link)
(defun org-docview-export (link description format)
"Export a docview link from Org files."
(defun org-docview-export (link description backend _info)
"Export a docview LINK with DESCRIPTION for BACKEND."
(let ((path (if (string-match "\\(.+\\)::.+" link) (match-string 1 link)
link))
(desc (or description link)))
(when (stringp path)
(setq path (expand-file-name path))
(cond
((eq format 'html) (format "<a href=\"%s\">%s</a>" path desc))
((eq format 'latex) (format "\\href{%s}{%s}" path desc))
((eq format 'ascii) (format "%s (%s)" desc path))
((eq backend 'html) (format "<a href=\"%s\">%s</a>" path desc))
((eq backend 'latex) (format "\\href{%s}{%s}" path desc))
((eq backend 'ascii) (format "[%s] (<%s>)" desc path))
(t path)))))
(defun org-docview-open (link _)
"Open docview: LINK."
(string-match "\\(.*?\\)\\(?:::\\([0-9]+\\)\\)?$" link)
(let ((path (match-string 1 link))
(page (and (match-beginning 2)
@ -82,7 +83,7 @@
(error "No such file: %s" path))
(when page (doc-view-goto-page page))))
(defun org-docview-store-link ()
(defun org-docview-store-link (&optional _interactive?)
"Store a link to a docview buffer."
(when (eq major-mode 'doc-view-mode)
;; This buffer is in doc-view-mode

3
lisp/org/ol-doi.el
View file

@ -40,7 +40,8 @@
(defun org-link-doi-open (path arg)
"Open a \"doi\" type link.
PATH is a the path to search for, as a string."
PATH is a the path to search for, as a string.
ARG is passed to `browse-url'."
(browse-url (url-encode-url (concat org-link-doi-server-url path)) arg))
(defun org-link-doi-export (path desc backend info)

11
lisp/org/ol-eshell.el
View file

@ -37,8 +37,8 @@
:store #'org-eshell-store-link)
(defun org-eshell-open (link _)
"Switch to an eshell buffer and execute a command line.
The link can be just a command line (executed in the default
"Switch to an eshell buffer and execute a command line for LINK.
The LINK can be just a command line (executed in the default
eshell buffer) or a command line prefixed by a buffer name
followed by a colon."
(let* ((buffer-and-command
@ -60,9 +60,10 @@ followed by a colon."
(insert command)
(eshell-send-input)))
(defun org-eshell-store-link ()
"Store a link that, when opened, switches back to the current eshell buffer
and the current working directory."
(defun org-eshell-store-link (&optional _interactive?)
"Store eshell link.
When opened, the link switches back to the current eshell buffer and
the current working directory."
(when (eq major-mode 'eshell-mode)
(let* ((command (concat "cd " (eshell/pwd)))
(link (concat (buffer-name) ":" command)))

3
lisp/org/ol-eww.el
View file

@ -62,7 +62,7 @@
"Open URL with Eww in the current buffer."
(eww url))
(defun org-eww-store-link ()
(defun org-eww-store-link (&optional _interactive?)
"Store a link to the url of an EWW buffer."
(when (eq major-mode 'eww-mode)
(org-link-store-props
@ -162,6 +162,7 @@ keep the structure of the Org file."
;; Additional keys for eww-mode
(defun org-eww-extend-eww-keymap ()
"Add ol-eww bindings to `eww-mode-map'."
(define-key eww-mode-map "\C-c\C-x\M-w" 'org-eww-copy-for-org-mode)
(define-key eww-mode-map "\C-c\C-x\C-w" 'org-eww-copy-for-org-mode))

36
lisp/org/ol-gnus.el
View file

@ -123,7 +123,7 @@ If `org-store-link' was called with a prefix arg the meaning of
(url-encode-url message-id))
(concat "gnus:" group "#" message-id)))
(defun org-gnus-store-link ()
(defun org-gnus-store-link (&optional _interactive?)
"Store a link to a Gnus folder or message."
(pcase major-mode
(`gnus-group-mode
@ -137,27 +137,23 @@ If `org-store-link' was called with a prefix arg the meaning of
(let* ((group
(pcase (gnus-find-method-for-group gnus-newsgroup-name)
(`(nnvirtual . ,_)
(save-excursion
(car (nnvirtual-map-article (gnus-summary-article-number)))))
(with-current-buffer gnus-summary-buffer
(save-excursion
(car (nnvirtual-map-article (gnus-summary-article-number))))))
(`(,(or `nnselect `nnir) . ,_) ; nnir is for Emacs < 28.
(save-excursion
(cond
((fboundp 'nnselect-article-group)
(nnselect-article-group (gnus-summary-article-number)))
((fboundp 'nnir-article-group)
(nnir-article-group (gnus-summary-article-number)))
(t
(error "No article-group variant bound")))))
(with-current-buffer gnus-summary-buffer
(save-excursion
(cond
((fboundp 'nnselect-article-group)
(nnselect-article-group (gnus-summary-article-number)))
((fboundp 'nnir-article-group)
(nnir-article-group (gnus-summary-article-number)))
(t
(error "No article-group variant bound"))))))
(_ gnus-newsgroup-name)))
(header (if (eq major-mode 'gnus-article-mode)
;; When in an article, first move to summary
;; buffer, with point on the summary of the
;; current article before extracting headers.
(save-window-excursion
(save-excursion
(gnus-article-show-summary)
(gnus-summary-article-header)))
(gnus-summary-article-header)))
(header (with-current-buffer gnus-summary-buffer
(save-excursion
(gnus-summary-article-header))))
(from (mail-header-from header))
(message-id (org-unbracket-string "<" ">" (mail-header-id header)))
(date (org-trim (mail-header-date header)))

20
lisp/org/ol-info.el
View file

@ -50,7 +50,7 @@
:insert-description #'org-info-description-as-command)
;; Implementation
(defun org-info-store-link ()
(defun org-info-store-link (&optional _interactive?)
"Store a link to an Info file and node."
(when (eq major-mode 'Info-mode)
(let ((link (concat "info:"
@ -139,13 +139,17 @@ If LINK is not an info link then DESC is returned."
"List of Emacs documents available.
Taken from <https://www.gnu.org/software/emacs/manual/html_mono/.>")
(defconst org-info-other-documents
(defcustom org-info-other-documents
'(("dir" . "https://www.gnu.org/manual/manual.html") ; index
("libc" . "https://www.gnu.org/software/libc/manual/html_mono/libc.html")
("make" . "https://www.gnu.org/software/make/manual/make.html"))
"Alist of documents generated from Texinfo source.
When converting info links to HTML, links to any one of these manuals are
converted to use these URL.")
converted to use these URL."
:group 'org-link
:type '(alist :key-type string :value-type string)
:package-version '(Org . "9.7")
:safe t)
(defun org-info-map-html-url (filename)
"Return URL or HTML file associated to Info FILENAME.
@ -153,11 +157,11 @@ If FILENAME refers to an official GNU document, return a URL pointing to
the official page for that document, e.g., use \"gnu.org\" for all Emacs
related documents. Otherwise, append \".html\" extension to FILENAME.
See `org-info-emacs-documents' and `org-info-other-documents' for details."
(cond ((member filename org-info-emacs-documents)
(format "https://www.gnu.org/software/emacs/manual/html_mono/%s.html"
filename))
((cdr (assoc filename org-info-other-documents)))
(t (concat filename ".html"))))
(cond ((cdr (assoc filename org-info-other-documents)))
((member filename org-info-emacs-documents)
(format "https://www.gnu.org/software/emacs/manual/html_mono/%s.html"
filename))
(t (concat filename ".html"))))
(defun org-info--expand-node-name (node)
"Expand Info NODE to HTML cross reference."

2
lisp/org/ol-irc.el
View file

@ -103,7 +103,7 @@ attributes that are found."
parts))
;;;###autoload
(defun org-irc-store-link ()
(defun org-irc-store-link (&optional _interactive?)
"Dispatch to the appropriate function to store a link to an IRC session."
(cond
((eq major-mode 'erc-mode)

50
lisp/org/ol-man.el
View file

@ -24,12 +24,17 @@
;;
;;; Commentary:
;; This file implements links to man pages from within Org mode.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'ol)
(org-link-set-parameters "man"
:complete #'org-man-complete
:follow #'org-man-open
:export #'org-man-export
:store #'org-man-store-link)
@ -37,15 +42,29 @@
(defcustom org-man-command 'man
"The Emacs command to be used to display a man page."
:group 'org-link
:type '(choice (const man) (const woman)))
:type '(choice (const man) (const :tag "WoMan (obsolete)" woman)))
(declare-function Man-translate-references "man" (ref))
(defun org-man-open (path _)
"Visit the manpage on PATH.
PATH should be a topic that can be thrown at the man command.
If PATH contains extra ::STRING which will use `occur' to search
matched strings in man buffer."
(require 'man) ; For `Man-translate-references'
(string-match "\\(.*?\\)\\(?:::\\(.*\\)\\)?$" path)
(let* ((command (match-string 1 path))
;; FIXME: Remove after we drop Emacs 29 support.
;; Working around security bug #66390.
(command (if (not (equal (Man-translate-references ";id") ";id"))
;; We are on Emacs that escapes man command args
;; (see Emacs commit 820f0793f0b).
command
;; Older Emacs without the fix - escape the
;; arguments ourselves.
(mapconcat 'identity
(mapcar #'shell-quote-argument
(split-string command "\\s-+"))
" ")))
(search (match-string 2 path))
(buffer (funcall org-man-command command)))
(when search
@ -63,7 +82,7 @@ matched strings in man buffer."
(set-window-point window point)
(set-window-start window point)))))))
(defun org-man-store-link ()
(defun org-man-store-link (&optional _interactive?)
"Store a link to a README file."
(when (memq major-mode '(Man-mode woman-mode))
;; This is a man page, we do make this link
@ -82,18 +101,31 @@ matched strings in man buffer."
(match-string 1 (buffer-name))
(error "Cannot create link to this man page")))
(defun org-man-export (link description format)
"Export a man page link from Org files."
(defun org-man-export (link description backend)
"Export a man page LINK with DESCRIPTION.
BACKEND is the current export backend."
(let ((path (format "http://man.he.net/?topic=%s&section=all" link))
(desc (or description link)))
(cond
((eq format 'html) (format "<a target=\"_blank\" href=\"%s\">%s</a>" path desc))
((eq format 'latex) (format "\\href{%s}{%s}" path desc))
((eq format 'texinfo) (format "@uref{%s,%s}" path desc))
((eq format 'ascii) (format "%s (%s)" desc path))
((eq format 'md) (format "[%s](%s)" desc path))
((eq backend 'html) (format "<a target=\"_blank\" href=\"%s\">%s</a>" path desc))
((eq backend 'latex) (format "\\href{%s}{%s}" path desc))
((eq backend 'texinfo) (format "@uref{%s,%s}" path desc))
((eq backend 'ascii) (format "[%s] (<%s>)" desc path))
((eq backend 'md) (format "[%s](%s)" desc path))
(t path))))
(defvar Man-completion-cache) ; Defined in `man'.
(defun org-man-complete (&optional _arg)
"Complete man pages for `org-insert-link'."
(require 'man)
(concat
"man:"
(let ((completion-ignore-case t) ; See `man' comments.
(Man-completion-cache)) ; See `man' implementation.
(completing-read
"Manual entry: "
'Man-completion-table))))
(provide 'ol-man)
;;; ol-man.el ends here

2
lisp/org/ol-mhe.el
View file

@ -80,7 +80,7 @@ supported by MH-E."
(org-link-set-parameters "mhe" :follow #'org-mhe-open :store #'org-mhe-store-link)
;; Implementation
(defun org-mhe-store-link ()
(defun org-mhe-store-link (&optional _interactive?)
"Store a link to an MH-E folder or message."
(when (or (eq major-mode 'mh-folder-mode)
(eq major-mode 'mh-show-mode))

2
lisp/org/ol-rmail.el
View file

@ -51,7 +51,7 @@
:store #'org-rmail-store-link)
;; Implementation
(defun org-rmail-store-link ()
(defun org-rmail-store-link (&optional _interactive?)
"Store a link to an Rmail folder or message."
(when (or (eq major-mode 'rmail-mode)
(eq major-mode 'rmail-summary-mode))

663
lisp/org/ol.el
View file

File diff suppressed because it is too large Load diff

2191
lisp/org/org-agenda.el
View file

File diff suppressed because it is too large Load diff

30
lisp/org/org-archive.el
View file

@ -34,9 +34,9 @@
(require 'org)
(require 'cl-lib)
(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" ())
(declare-function org-timestamp-to-now "org" (timestamp-string &optional seconds))
;; From org-element.el
(defvar org-element--cache-avoid-synchronous-headline-re-parsing)
@ -154,10 +154,10 @@ archive location, but not yet deleted from the original file.")
;;;###autoload
(defun org-add-archive-files (files)
"Splice the archive files into the list of files.
"Splice the archive FILES into the list of files.
This implies visiting all these files and finding out what the
archive file is."
(org-uniquify
(seq-uniq
(apply
'append
(mapcar
@ -166,7 +166,9 @@ archive file is."
nil
(with-current-buffer (org-get-agenda-file-buffer f)
(cons f (org-all-archive-files)))))
files))))
files))
#'file-equal-p
))
(defun org-all-archive-files ()
"List of all archive files used in the current buffer."
@ -252,8 +254,7 @@ direct children of this heading."
(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))
((find-file-noselect afile 'nowarn))
(t (error "Cannot access file \"%s\"" afile))))
(org-odd-levels-only
(if (local-variable-p 'org-odd-levels-only (current-buffer))
@ -477,9 +478,9 @@ Archiving time is retained in the ARCHIVE_TIME node property."
(goto-char e)
(or (bolp) (newline))
(insert leader org-archive-sibling-heading "\n")
(beginning-of-line 0)
(forward-line -1)
(org-toggle-tag org-archive-tag 'on))
(beginning-of-line 1)
(forward-line 0)
(if org-archive-reversed-order
(outline-next-heading)
(org-end-of-subtree t t))
@ -524,12 +525,12 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
(let (ts)
(and (re-search-forward org-ts-regexp end t)
(setq ts (match-string 0))
(< (org-time-stamp-to-now ts) 0)
(< (org-timestamp-to-now ts) 0)
(if (not (looking-at
(concat "--\\(" org-ts-regexp "\\)")))
(concat "--\\(" org-ts-regexp "\\)")))
(concat "old timestamp " ts)
(setq ts (concat "old timestamp " ts (match-string 0)))
(and (< (org-time-stamp-to-now (match-string 1)) 0)
(and (< (org-timestamp-to-now (match-string 1)) 0)
ts)))))
tag))
@ -590,8 +591,9 @@ don't move trees, but mark them with the ARCHIVE tag."
;;;###autoload
(defun org-toggle-archive-tag (&optional find-done)
"Toggle the archive tag for the current headline.
With prefix ARG, check all children of current headline and offer tagging
the children that do not contain any open TODO items."
With prefix argument FIND-DONE, check all children of current headline
and offer tagging the children that do not contain any open TODO
items."
(interactive "P")
(if (and (org-region-active-p) org-loop-over-headlines-in-active-region)
(let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level)
@ -608,7 +610,7 @@ the children that do not contain any open TODO items."
(org-back-to-heading t)
(setq set (org-toggle-tag org-archive-tag))
(when set (org-fold-subtree t)))
(and set (beginning-of-line 1))
(and set (forward-line 0))
(message "Subtree %s" (if set "archived" "unarchived"))))))
(defun org-archive-set-tag ()

161
lisp/org/org-attach.el
View file

@ -44,8 +44,12 @@
(declare-function dired-dwim-target-directory "dired-aux")
(declare-function dired-get-marked-files "dired" (&optional localp arg filter distinguish-one-marked error))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-contents-begin "org-element" (node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-inlinetask-goto-beginning "org-inlinetask" ())
(declare-function org-inlinetask-in-task-p "org-inlinetask" ())
@ -138,13 +142,13 @@ Selective means to respect the inheritance setting in
(const :tag "Inherit parent node attachments" t)
(const :tag "Respect org-use-property-inheritance" selective)))
(defcustom org-attach-store-link-p nil
(defcustom org-attach-store-link-p 'attached
"Non-nil means store a link to a file when attaching it.
When t, store the link to original file location.
When `file', store link to the attached file location.
When `attached', store attach: link to the attached file."
:group 'org-attach
:version "24.1"
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Don't store link" nil)
(const :tag "Link to origin location" t)
@ -297,67 +301,71 @@ ask the user instead, else remove without asking."
"The dispatcher for attachment commands.
Shows a list of commands and prompts for another key to execute a command."
(interactive)
(let ((dir (org-attach-dir nil 'no-fs-check))
c marker)
(let (c marker)
(when (eq major-mode 'org-agenda-mode)
(setq marker (or (get-text-property (point) 'org-hd-marker)
(get-text-property (point) 'org-marker)))
(unless marker
(error "No item in current line")))
(org-with-point-at marker
(if (and (featurep 'org-inlinetask)
(not (org-inlinetask-in-task-p)))
(org-with-limited-levels
(org-back-to-heading-or-point-min t))
(let ((dir (org-attach-dir nil 'no-fs-check)))
(if (and (featurep 'org-inlinetask)
(org-inlinetask-in-task-p))
(org-inlinetask-goto-beginning)
(org-back-to-heading-or-point-min t)))
(save-excursion
(save-window-excursion
(unless org-attach-expert
(org-switch-to-buffer-other-window "*Org Attach*")
(erase-buffer)
(setq cursor-type nil
header-line-format "Use C-v, M-v, C-n or C-p to navigate.")
(insert
(concat "Attachment folder:\n"
(or dir
"Can't find an existing attachment-folder")
(unless (and dir (file-directory-p dir))
"\n(Not yet created)")
"\n\n"
(format "Select an Attachment Command:\n\n%s"
(mapconcat
(lambda (entry)
(pcase entry
(`((,key . ,_) ,_ ,docstring)
(format "%c %s"
key
(replace-regexp-in-string "\n\\([\t ]*\\)"
" "
docstring
nil nil 1)))
(_
(user-error
"Invalid `org-attach-commands' item: %S"
entry))))
org-attach-commands
"\n")))))
(org-fit-window-to-buffer (get-buffer-window "*Org Attach*"))
(let ((msg (format "Select command: [%s]"
(concat (mapcar #'caar org-attach-commands)))))
(message msg)
(while (and (setq c (read-char-exclusive))
(memq c '(?\C-n ?\C-p ?\C-v ?\M-v)))
(org-scroll c t)))
(and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*"))))
(let ((command (cl-some (lambda (entry)
(and (memq c (nth 0 entry)) (nth 1 entry)))
org-attach-commands)))
(if (commandp command)
(command-execute command)
(error "No such attachment command: %c" c))))))
(not (org-inlinetask-in-task-p)))
(org-with-limited-levels
(org-back-to-heading-or-point-min t))
(if (and (featurep 'org-inlinetask)
(org-inlinetask-in-task-p))
(org-inlinetask-goto-beginning)
(org-back-to-heading-or-point-min t)))
(save-excursion
(save-window-excursion
(unless org-attach-expert
(switch-to-buffer-other-window "*Org Attach*")
(erase-buffer)
(setq cursor-type nil
header-line-format "Use C-v, M-v, C-n or C-p to navigate.")
(insert
(concat "Attachment folder:\n"
(or dir
"Can't find an existing attachment-folder")
(unless (and dir (file-directory-p dir))
"\n(Not yet created)")
"\n\n"
(format "Select an Attachment Command:\n\n%s"
(mapconcat
(lambda (entry)
(pcase entry
(`((,key . ,_) ,_ ,docstring)
(format "%c %s"
key
(replace-regexp-in-string "\n\\([\t ]*\\)"
" "
docstring
nil nil 1)))
(_
(user-error
"Invalid `org-attach-commands' item: %S"
entry))))
org-attach-commands
"\n"))))
(goto-char (point-min)))
(org-fit-window-to-buffer (get-buffer-window "*Org Attach*"))
(unwind-protect
(let ((msg (format "Select command: [%s]"
(concat (mapcar #'caar org-attach-commands)))))
(message msg)
(while (and (setq c (read-char-exclusive))
(memq c '(?\C-n ?\C-p ?\C-v ?\M-v)))
(org-scroll c t)))
(when-let ((window (get-buffer-window "*Org Attach*" t)))
(quit-window 'kill window))
(and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*")))))
(let ((command (cl-some (lambda (entry)
(and (memq c (nth 0 entry)) (nth 1 entry)))
org-attach-commands)))
(if (commandp command)
(command-execute command)
(error "No such attachment command: %c" c)))))))
;;;###autoload
(defun org-attach-dir (&optional create-if-not-exists-p no-fs-check)
@ -432,17 +440,26 @@ ignoring nils. If EXISTING is non-nil, then return the first path
found in the filesystem. Otherwise return the first non-nil value."
(let ((fun-list org-attach-id-to-path-function-list)
(base-dir (expand-file-name org-attach-id-dir))
(default-base-dir (expand-file-name "data/"))
preferred first)
(while (and fun-list
(not preferred))
(let* ((name (funcall (car fun-list) id))
(candidate (and name (expand-file-name name base-dir))))
(candidate (and name (expand-file-name name base-dir)))
;; Try the default value `org-attach-id-dir' as a fallback.
(candidate2 (and name (not (equal base-dir default-base-dir))
(expand-file-name name default-base-dir))))
(setq fun-list (cdr fun-list))
(when candidate
(if (or (not existing) (file-directory-p candidate))
(setq preferred candidate)
(unless first
(setq first candidate))))))
(setq first candidate)))
(when (and existing
candidate2
(not (file-directory-p candidate))
(file-directory-p candidate2))
(setq preferred candidate2)))))
(or preferred first)))
(defun org-attach-check-absolute-path (dir)
@ -512,9 +529,13 @@ DIR-property exists (that is different from the unset one)."
(defun org-attach-tag (&optional off)
"Turn the autotag on or (if OFF is set) off."
(when org-attach-auto-tag
(save-excursion
(org-back-to-heading t)
(org-toggle-tag org-attach-auto-tag (if off 'off 'on)))))
;; FIXME: There is currently no way to set #+FILETAGS
;; programatically. Do nothing when before first heading
;; (attaching to file) to avoid blocking error.
(unless (org-before-first-heading-p)
(save-excursion
(org-back-to-heading t)
(org-toggle-tag org-attach-auto-tag (if off 'off 'on))))))
(defun org-attach-untag ()
"Turn the autotag off."
@ -573,7 +594,7 @@ METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from
((eq method 'url)
(if (org--should-fetch-remote-resource-p file)
(url-copy-file file attach-file)
(error "The remote resource %S is considered unsafe, and will not be downloaded."
(error "The remote resource %S is considered unsafe, and will not be downloaded"
file))))
(run-hook-with-args 'org-attach-after-change-hook attach-dir)
(org-attach-tag)
@ -736,20 +757,20 @@ It is meant to be added to `org-export-before-parsing-hook'."
(save-excursion
(while (re-search-forward "attachment:" nil t)
(let ((link (org-element-context)))
(when (and (eq 'link (org-element-type link))
(when (and (org-element-type-p link 'link)
(string-equal "attachment"
(org-element-property :type link)))
(let* ((description (and (org-element-property :contents-begin link)
(let* ((description (and (org-element-contents-begin link)
(buffer-substring-no-properties
(org-element-property :contents-begin link)
(org-element-property :contents-end link))))
(org-element-contents-begin link)
(org-element-contents-end link))))
(file (org-element-property :path link))
(new-link (org-link-make-string
(concat "file:" (org-attach-expand file))
description)))
(goto-char (org-element-property :end link))
(goto-char (org-element-end link))
(skip-chars-backward " \t")
(delete-region (org-element-property :begin link) (point))
(delete-region (org-element-begin link) (point))
(insert new-link)))))))
(defun org-attach-follow (file arg)

105
lisp/org/org-capture.el
View file

@ -58,11 +58,13 @@
(declare-function org-at-table-p "org-table" (&optional table-type))
(declare-function org-clock-update-mode-line "org-clock" (&optional refresh))
(declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction))
(declare-function org-datetree-find-month-create (d &optional keep-restriction))
(declare-function org-datetree-find-month-create "org-datetree" (d &optional keep-restriction))
(declare-function org-decrypt-entry "org-crypt" ())
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-lineage "org-element" (datum &optional types with-self))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-lineage "org-element-ast" (datum &optional types with-self))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-encrypt-entry "org-crypt" ())
(declare-function org-insert-link "ol" (&optional complete-file link-location default-description))
(declare-function org-link-make-string "ol" (link &optional description))
@ -220,6 +222,9 @@ target Specification of where the captured item should be placed.
(clock)
File to the entry that is currently being clocked
(here)
The position of point
(function function-finding-location)
Most general way: write your own function which both visits
the file and moves point to the right location
@ -366,6 +371,10 @@ be replaced with content and expanded:
%^{prompt} Prompt the user for a string and replace this sequence with it.
A default value and a completion table can be specified like this:
%^{prompt|default|completion2|completion3|...}.
%^{prompt}X where X is one of g, G, t, T, u, U, C, or L.
Same as %^X (see above), but also supply custom
prompt/completions. Default value and completions as in
%^{prompt|default|...}X are allowed.
%? After completing the template, position cursor here.
%\\1 ... %\\N Insert the text entered at the nth %^{prompt}, where N
is a number, starting from 1.
@ -393,7 +402,7 @@ 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
:package-version '(Org . "9.6")
:package-version '(Org . "9.7")
:set (lambda (s v) (set-default-toplevel-value s (org-capture-upgrade-templates v)))
:type
(let ((file-variants '(choice :tag "Filename "
@ -496,12 +505,6 @@ The capture buffer is current and still narrowed."
:version "24.1"
:type 'hook)
(defcustom org-capture-bookmark t
"When non-nil, add bookmark pointing at the last stored position when capturing."
:group 'org-capture
:version "24.3"
:type 'boolean)
;;; The property list for keeping information about the capture process
(defvar org-capture-plist nil
@ -579,7 +582,9 @@ this template to be accessible only from `message-mode' buffers,
use this:
(setq org-capture-templates-contexts
\\='((\"c\" ((in-mode . \"message-mode\")))))
\\='((\"c\" ((in-mode . \"message-mode\")))
(\"d\" (my-context-function
(in-mode . \"org-mode\")))))
Here are the available contexts definitions:
@ -889,10 +894,16 @@ captured item after finalizing."
(goto-char (+ size pos))
(goto-char (if (< ipt pos) (+ size pos) pos))))))
;; Kill the target buffer if that is desired
(when (and base-buffer new-buffer kill-buffer)
(with-current-buffer base-buffer (save-buffer))
(kill-buffer base-buffer))
(if (and base-buffer org-note-abort new-buffer)
;; Unconditionally kill the new buffer when capture is
;; aborted.
(with-current-buffer base-buffer
(set-buffer-modified-p nil)
(kill-buffer))
;; Kill the target buffer if that is desired
(when (and base-buffer new-buffer kill-buffer)
(with-current-buffer base-buffer (save-buffer))
(kill-buffer base-buffer)))
;; Restore the window configuration before capture
(set-window-configuration return-wconf))
@ -985,14 +996,15 @@ Store them in the capture property list."
(let ((target-entry-p t))
(save-excursion
(pcase (or target (org-capture-get :target))
(`here
((or `here
`(here))
(org-capture-put :exact-position (point) :insert-here t))
(`(file ,path)
(set-buffer (org-capture-target-buffer path))
(org-capture-put-target-region-and-position)
(widen)
(setq target-entry-p nil))
(`(id ,id)
(`(id ,(and id (or (pred stringp) (pred symbolp))))
(pcase (org-id-find id)
(`(,path . ,position)
(set-buffer (org-capture-target-buffer path))
@ -1000,7 +1012,7 @@ Store them in the capture property list."
(org-capture-put-target-region-and-position)
(goto-char position))
(_ (error "Cannot find target ID \"%s\"" id))))
(`(file+headline ,path ,headline)
(`(file+headline ,path ,(and headline (pred stringp)))
(set-buffer (org-capture-target-buffer path))
;; Org expects the target file to be in Org mode, otherwise
;; it throws an error. However, the default notes files
@ -1017,12 +1029,12 @@ Store them in the capture property list."
(if (re-search-forward (format org-complex-heading-regexp-format
(regexp-quote headline))
nil t)
(beginning-of-line)
(forward-line 0)
(goto-char (point-max))
(unless (bolp) (insert "\n"))
(insert "* " headline "\n")
(beginning-of-line 0)))
(`(file+olp ,path . ,outline-path)
(forward-line -1)))
(`(file+olp ,path . ,(and outline-path (guard outline-path)))
(let ((m (org-find-olp (cons (org-capture-expand-file path)
outline-path))))
(set-buffer (marker-buffer m))
@ -1030,7 +1042,7 @@ Store them in the capture property list."
(widen)
(goto-char m)
(set-marker m nil)))
(`(file+regexp ,path ,regexp)
(`(file+regexp ,path ,(and regexp (pred stringp)))
(set-buffer (org-capture-target-buffer path))
(org-capture-put-target-region-and-position)
(widen)
@ -1098,7 +1110,7 @@ Store them in the capture property list."
;; the following is the keep-restriction argument for
;; org-datetree-find-date-create
(when outline-path 'subtree-at-point))))
(`(file+function ,path ,function)
(`(file+function ,path ,(and function (pred functionp)))
(set-buffer (org-capture-target-buffer path))
(org-capture-put-target-region-and-position)
(widen)
@ -1106,7 +1118,7 @@ Store them in the capture property list."
(org-capture-put :exact-position (point))
(setq target-entry-p
(and (derived-mode-p 'org-mode) (org-at-heading-p))))
(`(function ,fun)
(`(function ,(and fun (pred functionp)))
(funcall fun)
(org-capture-put :exact-position (point))
(setq target-entry-p
@ -1162,9 +1174,9 @@ When INHIBIT-WCONF-STORE is non-nil, don't store the window configuration, as it
may have been stored before."
(unless inhibit-wconf-store
(org-capture-put :return-to-wconf (current-window-configuration)))
(delete-other-windows)
(org-switch-to-buffer-other-window
(org-capture-get-indirect-buffer (org-capture-get :buffer) "CAPTURE"))
(pop-to-buffer
(org-capture-get-indirect-buffer (org-capture-get :buffer) "CAPTURE")
'(org-display-buffer-split))
(widen)
(org-fold-show-all)
(goto-char (org-capture-get :pos))
@ -1262,7 +1274,7 @@ may have been stored before."
(catch :found
(while (re-search-forward item-regexp end t)
(when (setq item (org-element-lineage
(org-element-at-point) '(plain-list) t))
(org-element-at-point) 'plain-list t))
(goto-char (org-element-property (if prepend? :post-affiliated
:contents-end)
item))
@ -1304,7 +1316,7 @@ may have been stored before."
(point-marker))))
(when item
(let ((i (save-excursion
(goto-char (org-element-property :post-affiliated item))
(goto-char (org-element-post-affiliated item))
(org-current-text-indentation))))
(save-excursion
(goto-char beg)
@ -1367,13 +1379,13 @@ may have been stored before."
;; Narrow to the table, possibly creating one if necessary.
(catch :found
(while (re-search-forward org-table-dataline-regexp end t)
(pcase (org-element-lineage (org-element-at-point) '(table) t)
(pcase (org-element-lineage (org-element-at-point) 'table t)
(`nil nil)
((pred (lambda (e) (eq 'table.el (org-element-property :type e))))
nil)
(table
(goto-char (org-element-property :contents-end table))
(narrow-to-region (org-element-property :post-affiliated table)
(goto-char (org-element-contents-end table))
(narrow-to-region (org-element-post-affiliated table)
(point))
(throw :found t))))
;; No table found. Create it with an empty header.
@ -1403,7 +1415,7 @@ may have been stored before."
(goto-char (point-min))
(cond
((not (re-search-forward org-table-hline-regexp nil t)))
((re-search-forward org-table-dataline-regexp nil t) (beginning-of-line))
((re-search-forward org-table-dataline-regexp nil t) (forward-line 0))
(t (goto-char (org-table-end)))))
(t
(goto-char (org-table-end))))
@ -1492,10 +1504,15 @@ Of course, if exact position has been required, just put it there."
(point))))))
(with-current-buffer (buffer-base-buffer (current-buffer))
(org-with-point-at pos
(when org-capture-bookmark
;; FIXME: `org-capture-bookmark' is obsolete. To be removed
;; in future Org releases.
(when (with-no-warnings org-capture-bookmark)
(let ((bookmark (plist-get org-bookmark-names-plist :last-capture)))
(when bookmark (with-demoted-errors "Bookmark set error: %S"
(bookmark-set bookmark)))))
(when bookmark
(condition-case err
(bookmark-set bookmark)
(error
(message "Bookmark set error: %S" err))))))
(move-marker org-capture-last-stored-marker (point))))))
(defun org-capture-narrow (beg end)
@ -1658,12 +1675,12 @@ Expansion occurs in a temporary Org mode buffer."
(org-no-properties org-clock-heading)
""))
(v-K (if (marker-buffer org-clock-marker)
(org-link-make-string
(format "%s::*%s"
(buffer-file-name (marker-buffer org-clock-marker))
v-k)
v-k)
""))
(let ((original-link-plist org-store-link-plist)
(clocked-task-link (org-with-point-at org-clock-marker
(org-store-link nil nil))))
(setq org-store-link-plist original-link-plist)
clocked-task-link)
""))
(v-f (or (org-capture-get :original-file-nondirectory) ""))
(v-F (or (org-capture-get :original-file) ""))
(org-capture--clipboards
@ -1680,7 +1697,7 @@ Expansion occurs in a temporary Org mode buffer."
(message "no template") (ding)
(sit-for 1))
(save-window-excursion
(org-switch-to-buffer-other-window (get-buffer-create "*Capture*"))
(switch-to-buffer-other-window (get-buffer-create "*Capture*"))
(erase-buffer)
(setq buffer-file-name nil)
(setq mark-active nil)
@ -1852,7 +1869,7 @@ Expansion occurs in a temporary Org mode buffer."
(let* ((upcase? (equal (upcase key) key))
(org-end-time-was-given nil)
(time (org-read-date upcase? t nil prompt)))
(org-insert-time-stamp
(org-insert-timestamp
time (or org-time-was-given upcase?)
(member key '("u" "U"))
nil nil (list org-end-time-was-given))))

267
lisp/org/org-clock.el
View file

@ -36,9 +36,11 @@
(declare-function calendar-iso-to-absolute "cal-iso" (date))
(declare-function notifications-notify "notifications" (&rest params))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(declare-function org-element--cache-active-p "org-element" ())
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(defvar org-element-use-cache)
(declare-function org-inlinetask-at-task-p "org-inlinetask" ())
(declare-function org-inlinetask-goto-beginning "org-inlinetask" ())
@ -51,6 +53,9 @@
(declare-function org-dynamic-block-define "org" (type func))
(declare-function w32-notification-notify "w32fns.c" (&rest params))
(declare-function w32-notification-close "w32fns.c" (&rest params))
(declare-function dbus-list-activatable-names "dbus" (&optional bus))
(declare-function dbus-call-method "dbus" (bus service path interface method &rest args))
(declare-function dbus-get-property "dbus" (bus service path interface property))
(declare-function haiku-notifications-notify "haikuselect.c")
(declare-function android-notifications-notify "androidselect.c")
@ -127,7 +132,7 @@ clocking out."
"Rounding minutes when clocking in or out.
The default value is 0 so that no rounding is done.
When set to a non-integer value, use the car of
`org-time-stamp-rounding-minutes', like for setting a time-stamp.
`org-timestamp-rounding-minutes', like for setting a timestamp.
E.g. if `org-clock-rounding-minutes' is set to 5, time is 14:47
and you clock in: then the clock starts at 14:45. If you clock
@ -346,14 +351,16 @@ For more information, see `org-clocktable-write-default'."
:version "24.1"
:type 'function)
;; FIXME: translate es and nl last string "Clock summary at"
(defcustom org-clock-clocktable-language-setup
'(("en" "File" "L" "Timestamp" "Headline" "Time" "ALL" "Total time" "File time" "Clock summary at")
("es" "Archivo" "N" "Fecha y hora" "Tarea" "Tiempo" "TODO" "Tiempo total" "Tiempo archivo" "Clock summary at")
("fr" "Fichier" "N" "Horodatage" "En-tête" "Durée" "TOUT" "Durée totale" "Durée fichier" "Horodatage sommaire à")
("nl" "Bestand" "N" "Tijdstip" "Hoofding" "Duur" "ALLES" "Totale duur" "Bestandstijd" "Clock summary at")
("de" "Datei" "E" "Zeitstempel" "Kopfzeile" "Dauer" "GESAMT"
"Gesamtdauer" "Dateizeit" "Erstellt am"))
'(("en" "File" "L" "Timestamp" "Headline" "Time" "ALL" "Total time" "File time" "Clock summary at")
("de" "Datei" "E" "Zeitstempel" "Kopfzeile" "Dauer" "GESAMT" "Gesamtdauer" "Dateizeit" "Erstellt am")
("es" "Archivo" "N" "Fecha y hora" "Tarea" "Duración" "TODO" "Duración total" "Tiempo archivo" "Generado el")
("fr" "Fichier" "N" "Horodatage" "En-tête" "Durée" "TOUT" "Durée totale" "Durée fichier" "Horodatage sommaire à")
("nl" "Bestand" "N" "Tijdstip" "Rubriek" "Duur" "ALLES" "Totale duur" "Bestandstijd" "Klok overzicht op")
("nn" "Fil" "N" "Tidspunkt" "Overskrift" "Tid" "ALLE" "Total tid" "Filtid" "Tidsoversyn")
("pl" "Plik" "P" "Data i godzina" "Nagłówek" "Czas" "WSZYSTKO" "Czas całkowity" "Czas pliku" "Poddumowanie zegara na")
("pt-BR" "Arquivo" "N" "Data e hora" "Título" "Hora" "TODOS" "Hora total" "Hora do arquivo" "Resumo das horas em")
("sk" "Súbor" "L" "Časová značka" "Záhlavie" "Čas" "VŠETKO" "Celkový čas" "Čas súboru" "Časový súhrn pre"))
"Terms used in clocktable, translated to different languages."
:group 'org-clocktable
:version "24.1"
@ -413,8 +420,8 @@ play with them."
:type 'string)
(defcustom org-clock-clocked-in-display 'mode-line
"When clocked in for a task, Org can display the current
task and accumulated time in the mode line and/or frame title.
"Where to display clocked in task and accumulated time when clocked in.
Allowed values are:
both displays in both mode line and frame title
@ -440,7 +447,9 @@ This uses the same format as `frame-title-format', which see."
:group 'org-clock
:type 'sexp)
(defcustom org-clock-x11idle-program-name "x11idle"
(defcustom org-clock-x11idle-program-name
(if (executable-find "xprintidle")
"xprintidle" "x11idle")
"Name of the program which prints X11 idle time in milliseconds.
you can do \"~$ sudo apt-get install xprintidle\" if you are using
@ -449,8 +458,7 @@ a Debian-based distribution.
Alternatively, can find x11idle.c in
https://orgmode.org/worg/code/scripts/x11idle.c"
:group 'org-clock
:version "24.4"
:package-version '(Org . "8.0")
:package-version '(Org . "9.7")
:type 'string)
(defcustom org-clock-goto-before-context 2
@ -508,7 +516,11 @@ to add an effort property.")
(defvar org-clock-in-hook nil
"Hook run when starting the clock.")
(defvar org-clock-out-hook nil
"Hook run when stopping the current clock.")
"Hook run when stopping the current clock.
The point is at the current clock line when the hook is executed.
The hook functions can access `org-clock-out-removed-last-clock' to
check whether the latest CLOCK line has been cleared.")
(defvar org-clock-cancel-hook nil
"Hook run when canceling the current clock.")
@ -562,6 +574,10 @@ of a different task.")
Assume S in the English term to translate. Return S as-is if it
cannot be translated."
(or (nth (pcase s
;; "L" stands for "Level"
;; "ALL" stands for a line summarizing clock data across
;; all the files, when the clocktable includes multiple
;; files.
("File" 1) ("L" 2) ("Timestamp" 3) ("Headline" 4) ("Time" 5)
("ALL" 6) ("Total time" 7) ("File time" 8) ("Clock summary at" 9))
(assoc-string language org-clock-clocktable-language-setup t))
@ -576,6 +592,7 @@ cannot be translated."
(org-no-properties (org-get-heading t t t t))))))
(defun org-clock-menu ()
"Pop up org-clock menu."
(interactive)
(popup-menu
'("Clock"
@ -585,7 +602,12 @@ cannot be translated."
["Switch task" (lambda () (interactive) (org-clock-in '(4))) :active t :keys "C-u C-c C-x C-i"])))
(defun org-clock-history-push (&optional pos buffer)
"Push a marker to the clock history."
"Push point marker to the clock history.
When POS is provided, use it as marker point.
When BUFFER and POS are provided, use marker at POS in base buffer of
BUFFER."
;; When buffer is provided, POS must be provided.
(cl-assert (or (not buffer) pos))
(setq org-clock-history-length (max 1 org-clock-history-length))
(let ((m (move-marker (make-marker)
(or pos (point)) (org-base-buffer
@ -605,7 +627,10 @@ cannot be translated."
(push m org-clock-history)))
(defun org-clock-save-markers-for-cut-and-paste (beg end)
"Save relative positions of markers in region."
"Save relative positions of markers in region BEG..END.
Save `org-clock-marker', `org-clock-hd-marker',
`org-clock-default-task', `org-clock-interrupted-task', and the
markers in `org-clock-history'."
(org-check-and-save-marker org-clock-marker beg end)
(org-check-and-save-marker org-clock-hd-marker beg end)
(org-check-and-save-marker org-clock-default-task beg end)
@ -631,6 +656,7 @@ cannot be translated."
(defun org-clock-select-task (&optional prompt)
"Select a task that was recently associated with clocking.
PROMPT is the prompt text to be used, as a string.
Return marker position of the selected task. Raise an error if
there is no recent clock to choose from."
(let (och chl sel-list rpl (i 0) s)
@ -641,7 +667,7 @@ there is no recent clock to choose from."
(if (zerop chl)
(user-error "No recent clock")
(save-window-excursion
(org-switch-to-buffer-other-window
(switch-to-buffer-other-window
(get-buffer-create "*Clock Task Select*"))
(erase-buffer)
(when (marker-buffer org-clock-default-task)
@ -671,8 +697,11 @@ there is no recent clock to choose from."
;; `fit-window-to-buffer'
(fit-window-to-buffer nil nil (if (< chl 10) chl (+ 5 chl)))
(message (or prompt "Select task for clocking:"))
(setq cursor-type nil rpl (read-char-exclusive))
(kill-buffer)
(unwind-protect (setq cursor-type nil rpl (read-char-exclusive))
(when-let ((window (get-buffer-window "*Clock Task Select*" t)))
(quit-window 'kill window))
(when (get-buffer "*Clock Task Select*")
(kill-buffer "*Clock Task Select*")))
(cond
((eq rpl ?q) nil)
((eq rpl ?x) nil)
@ -781,6 +810,7 @@ previous clocking intervals."
60)))
(+ currently-clocked-time (or org-clock-total-time 0))))
;;;###autoload
(defun org-clock-modify-effort-estimate (&optional value)
"Add to or set the effort estimate of the item currently being clocked.
VALUE can be a number of minutes, or a string with format hh:mm or mm.
@ -911,7 +941,7 @@ If CLOCK-SOUND is non-nil, it overrides `org-clock-sound'."
(if (executable-find "aplay")
(start-process "org-clock-play-notification" nil
"aplay" file)
(condition-case nil
(condition-case-unless-debug nil
(play-sound-file file)
(error (beep t) (beep t))))))))))
@ -928,9 +958,11 @@ If CLOCK-SOUND is non-nil, it overrides `org-clock-sound'."
(save-excursion
(goto-char (point-min))
(while (re-search-forward org-clock-re nil t)
(push (cons (copy-marker (match-end 1) t)
(org-time-string-to-time (match-string 1)))
clocks))))
(when (save-match-data
(org-element-type-p (org-element-at-point) 'clock))
(push (cons (copy-marker (match-end 1) t)
(org-time-string-to-time (match-string 1)))
clocks)))))
clocks))
(defsubst org-is-active-clock (clock)
@ -944,7 +976,7 @@ If CLOCK-SOUND is non-nil, it overrides `org-clock-sound'."
`(with-current-buffer (marker-buffer (car ,clock))
(org-with-wide-buffer
(goto-char (car ,clock))
(beginning-of-line)
(forward-line 0)
,@forms)))
(defmacro org-with-clock (clock &rest forms)
@ -1050,8 +1082,8 @@ CLOCK is a cons cell of the form (MARKER START-TIME)."
(catch 'exit
(while (re-search-backward drawer-re beg t)
(let ((element (org-element-at-point)))
(when (eq (org-element-type element) 'drawer)
(when (> (org-element-property :end element) (car clock))
(when (org-element-type-p element 'drawer)
(when (> (org-element-end element) (car clock))
(org-fold-hide-drawer-toggle 'off nil element))
(throw 'exit nil)))))))))))
@ -1226,6 +1258,27 @@ If `only-dangling-p' is non-nil, only ask to resolve dangling
"Return the current X11 idle time in seconds."
(/ (string-to-number (shell-command-to-string org-clock-x11idle-program-name)) 1000))
(defvar org-logind-dbus-session-path
(when (and (boundp 'dbus-runtime-version)
(require 'dbus nil t)
(member "org.freedesktop.login1" (dbus-list-activatable-names)))
(ignore-errors
(dbus-call-method
:system "org.freedesktop.login1"
"/org/freedesktop/login1"
"org.freedesktop.login1.Manager"
"GetSessionByPID" (emacs-pid))))
"D-Bus session path for the elogind interface.")
(defun org-logind-user-idle-seconds ()
"Return the number of idle seconds for the user according to logind."
(- (float-time)
(/ (dbus-get-property
:system "org.freedesktop.login1"
org-logind-dbus-session-path
"org.freedesktop.login1.Session" "IdleSinceHint")
1e6)))
(defun org-user-idle-seconds ()
"Return the number of seconds the user has been idle for.
This routine returns a floating point number."
@ -1234,6 +1287,13 @@ This routine returns a floating point number."
(org-mac-idle-seconds))
((and (eq window-system 'x) org-x11idle-exists-p)
(org-x11-idle-seconds))
((and
org-logind-dbus-session-path
(dbus-get-property
:system "org.freedesktop.login1"
org-logind-dbus-session-path
"org.freedesktop.login1.Session" "IdleHint"))
(org-logind-user-idle-seconds))
(t
(org-emacs-idle-seconds))))
@ -1291,8 +1351,6 @@ time as the start time. See `org-clock-continuously' to make this
the default behavior."
(interactive "P")
(setq org-clock-notification-was-shown nil)
(unless org-element-use-cache
(org-refresh-effort-properties))
(catch 'abort
(let ((interrupting (and (not org-clock-resolving-clocks-due-to-idleness)
(org-clocking-p)))
@ -1370,8 +1428,8 @@ the default behavior."
(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-clock-in-switch-to-state
"\\(?:[ \t]\\|$\\)"))))
(org-todo org-clock-in-switch-to-state)))
(setq org-clock-heading (org-clock--mode-line-heading))
(org-clock-find-position org-clock-in-resume)
@ -1397,12 +1455,15 @@ the default behavior."
(sit-for 2)
(throw 'abort nil))
(t
;; Make sure that point moves after clock line upon
;; inserting it. Then, users can continue typing even if
;; point was right where the clock is inserted.
(insert-before-markers-and-inherit "\n")
(backward-char 1)
(when (and (save-excursion
(end-of-line 0)
(org-in-item-p)))
(beginning-of-line 1)
(forward-line 0)
(indent-line-to (max 0 (- (current-indentation) 2))))
(insert-and-inherit org-clock-string " ")
(setq org-clock-effort (org-entry-get (point) org-effort-property))
@ -1422,8 +1483,8 @@ the default behavior."
leftover)
start-time
(org-current-time org-clock-rounding-minutes t)))
(setq ts (org-insert-time-stamp org-clock-start-time
'with-hm 'inactive))
(setq ts (org-insert-timestamp org-clock-start-time
'with-hm 'inactive))
(org-indent-line)))
(move-marker org-clock-marker (point) (buffer-base-buffer))
(move-marker org-clock-hd-marker
@ -1459,6 +1520,33 @@ the default behavior."
(message "Clock starts at %s - %s" ts org--msg-extra)
(run-hooks 'org-clock-in-hook))))))
(defvar org-clock--auto-clockout-timer-obj nil
"Timer object holding the existing clockout timer.")
(defun org-clock--auto-clockout-maybe ()
"Clock out the currently clocked in task when idle.
See `org-clock-auto-clockout-timer' to set the idle time span.
This function is to be called by a timer."
(when (and (numberp org-clock-auto-clockout-timer)
org-clock-current-task)
(let ((user-idle-seconds (org-user-idle-seconds)))
(cond
;; Already idle. Clock out.
((>= user-idle-seconds org-clock-auto-clockout-timer)
(setq org-clock--auto-clockout-timer-obj nil)
(org-clock-out))
;; Emacs is idle but system is not. Retry assuming that system will remain idle.
((>= (org-emacs-idle-seconds) org-clock-auto-clockout-timer)
(setq org-clock--auto-clockout-timer-obj
(run-with-timer
(- org-clock-auto-clockout-timer user-idle-seconds)
nil #'org-clock--auto-clockout-maybe)))
;; Emacs is not idle. Check again next time we are idle.
(t
(setq org-clock--auto-clockout-timer-obj
(run-with-idle-timer
org-clock-auto-clockout-timer nil #'org-clock--auto-clockout-maybe)))))))
(defun org-clock-auto-clockout ()
"Clock out the currently clocked in task if Emacs is idle.
See `org-clock-auto-clockout-timer' to set the idle time span.
@ -1466,9 +1554,11 @@ See `org-clock-auto-clockout-timer' to set the idle time span.
This is only effective when `org-clock-auto-clockout-insinuate'
is present in the user configuration."
(when (and (numberp org-clock-auto-clockout-timer)
org-clock-current-task)
(run-with-idle-timer
org-clock-auto-clockout-timer nil #'org-clock-out)))
org-clock-current-task
(not (timerp org-clock--auto-clockout-timer-obj)))
(setq org-clock--auto-clockout-timer-obj
(run-with-idle-timer
org-clock-auto-clockout-timer nil #'org-clock--auto-clockout-maybe))))
;;;###autoload
(defun org-clock-toggle-auto-clockout ()
@ -1576,9 +1666,9 @@ line and position cursor in that line."
" *\\sw+ +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$")))
(while (re-search-forward open-clock-re end t)
(let ((element (org-element-at-point)))
(when (and (eq (org-element-type element) 'clock)
(when (and (org-element-type-p element 'clock)
(eq (org-element-property :status element) 'running))
(beginning-of-line)
(forward-line 0)
(throw 'exit t))))))
;; Look for an existing clock drawer.
(when drawer
@ -1586,8 +1676,8 @@ line and position cursor in that line."
(let ((drawer-re (concat "^[ \t]*:" (regexp-quote drawer) ":[ \t]*$")))
(while (re-search-forward drawer-re end t)
(let ((element (org-element-at-point)))
(when (eq (org-element-type element) 'drawer)
(let ((cend (org-element-property :contents-end element)))
(when (org-element-type-p element 'drawer)
(let ((cend (org-element-contents-end element)))
(if (and (not org-log-states-order-reversed) cend)
(goto-char cend)
(forward-line))
@ -1600,7 +1690,7 @@ line and position cursor in that line."
(save-excursion
(while (re-search-forward clock-re end t)
(let ((element (org-element-at-point)))
(when (eq (org-element-type element) 'clock)
(when (org-element-type-p element 'clock)
(setq positions (cons (line-beginning-position) positions)
count (1+ count))))))
(cond
@ -1608,19 +1698,18 @@ line and position cursor in that line."
(org-fold-core-ignore-modifications
;; Skip planning line and property drawer, if any.
(org-end-of-meta-data)
(unless (bolp) (insert-and-inherit "\n"))
(unless (bolp) (insert-before-markers-and-inherit "\n"))
;; Create a new drawer if necessary.
(when (and org-clock-into-drawer
(or (not (wholenump org-clock-into-drawer))
(< org-clock-into-drawer 2)))
(let ((beg (point)))
(insert-and-inherit ":" drawer ":\n:END:\n")
;; Make sure that point moves after drawer upon
;; inserting it. Then, users can continue typing even
;; if point was right where the clock is inserted.
(insert-before-markers-and-inherit ":" drawer ":\n:END:\n")
(org-indent-region beg (point))
(if (eq org-fold-core-style 'text-properties)
(org-fold-region
(line-end-position -1) (1- (point)) t 'drawer)
(org-fold-region
(line-end-position -1) (1- (point)) t 'outline))
(org-fold-region (line-end-position -1) (1- (point)) t 'drawer)
(forward-line -1)))))
;; When a clock drawer needs to be created because of the
;; number of clock items or simply if it is missing, collect
@ -1645,13 +1734,13 @@ line and position cursor in that line."
"\n:END:\n")
(let ((end (point-marker)))
(goto-char beg)
(save-excursion (insert-and-inherit ":" drawer ":\n"))
(save-excursion (insert-before-markers-and-inherit ":" drawer ":\n"))
(org-fold-region (line-end-position) (1- end) t 'outline)
(org-indent-region (point) end)
(forward-line)
(unless org-log-states-order-reversed
(goto-char end)
(beginning-of-line -1))
(forward-line -2))
(set-marker end nil)))))
(org-log-states-order-reversed (goto-char (car (last positions))))
(t (goto-char (car positions))))))))
@ -1664,6 +1753,11 @@ and current `frame-title-format' is equal to `org-clock-frame-title-format'."
(equal frame-title-format org-clock-frame-title-format))
(setq frame-title-format org-frame-title-format-backup)))
(defvar org-clock-out-removed-last-clock nil
"When non-nil, the last `org-clock-out' removed the clock line.
This can happen when `org-clock-out-remove-zero-time-clocks' is set to
non-nil and the latest clock took 0 minutes.")
;;;###autoload
(defun org-clock-out (&optional switch-to-state fail-quietly at-time)
"Stop the currently running clock.
@ -1694,7 +1788,7 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
(save-restriction
(widen)
(goto-char org-clock-marker)
(beginning-of-line 1)
(forward-line 0)
(if (and (looking-at (concat "[ \t]*" org-keyword-time-regexp))
(equal (match-string 1) org-clock-string))
(setq ts (match-string 2))
@ -1703,7 +1797,7 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
(delete-region (point) (line-end-position))
(org-fold-core-ignore-modifications
(insert-and-inherit "--")
(setq te (org-insert-time-stamp (or at-time now) 'with-hm 'inactive))
(setq te (org-insert-timestamp (or at-time now) 'with-hm 'inactive))
(setq s (org-time-convert-to-integer
(time-subtract
(org-time-string-to-time te)
@ -1742,10 +1836,10 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
(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
"\\>"))))
(concat
org-outline-regexp "[ \t]*"
org-clock-out-switch-to-state
"\\(?:[ \t]\\|$\\)"))))
(org-todo org-clock-out-switch-to-state))))))
(force-mode-line-update)
(message (if remove
@ -1754,6 +1848,7 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
te (org-duration-from-minutes (+ (* 60 h) m)))
(unless (org-clocking-p)
(setq org-clock-current-task nil))
(setq org-clock-out-removed-last-clock remove)
(run-hooks 'org-clock-out-hook)
;; Add a note, but only if we didn't remove the clock line.
(when (and org-log-note-clock-out (not remove))
@ -1948,17 +2043,30 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
(save-excursion
(goto-char (point-max))
(while (re-search-backward re nil t)
(let ((element-type
(org-element-type
(save-match-data
(org-element-at-point)))))
(let* ((element (save-match-data (org-element-at-point)))
(element-type (org-element-type element)))
(cond
((and (eq element-type 'clock) (match-end 2))
;; Two time stamps.
(let* ((ss (match-string 2))
(se (match-string 3))
(ts (org-time-string-to-seconds ss))
(te (org-time-string-to-seconds se))
(let* ((timestamp (org-element-property :value element))
(ts (float-time
(org-encode-time
(list 0
(org-element-property :minute-start timestamp)
(org-element-property :hour-start timestamp)
(org-element-property :day-start timestamp)
(org-element-property :month-start timestamp)
(org-element-property :year-start timestamp)
nil -1 nil))))
(te (float-time
(org-encode-time
(list 0
(org-element-property :minute-end timestamp)
(org-element-property :hour-end timestamp)
(org-element-property :day-end timestamp)
(org-element-property :month-end timestamp)
(org-element-property :year-end timestamp)
nil -1 nil))))
(dt (- (if tend (min te tend) te)
(if tstart (max ts tstart) ts))))
(when (> dt 0) (cl-incf t1 (floor dt 60)))))
@ -2358,7 +2466,7 @@ have priority."
d (+ d shift)))
((or `week `thisweek)
(let* ((ws (or wstart 1))
(diff (+ (* -7 shift) (if (= dow 0) (- 7 ws) (- dow ws)))))
(diff (+ (* -7 shift) (mod (+ dow 7 (- ws)) 7))))
(setq m 0 h org-extend-today-until d (- d diff) d1 (+ 7 d))))
((or `month `thismonth)
(setq h org-extend-today-until m 0 d (or mstart 1)
@ -2509,7 +2617,7 @@ the currently selected interval size."
(goto-char b)
(insert ins)
(delete-region (point) (+ (point) (- e b)))
(beginning-of-line 1)
(forward-line 0)
(org-update-dblock)
t)))))
@ -2811,13 +2919,13 @@ from the dynamic block definition."
(if timestamp (concat ts "|") "") ;timestamp, maybe
(if tags (concat (mapconcat #'identity tgs ", ") "|") "") ;tags, maybe
(if properties ;properties columns, maybe
(concat (mapconcat (lambda (p) (or (cdr (assoc p props)) ""))
properties
"|")
"|")
(concat (mapconcat (lambda (p) (or (cdr (assoc p props)) ""))
properties
"|")
"|")
"")
(if indent ;indentation
(org-clocktable-indent-string level)
(org-clocktable-indent-string level)
"")
(format-field headline)
;; Empty fields for higher levels.
@ -2825,7 +2933,7 @@ from the dynamic block definition."
(format-field (org-duration-from-minutes time))
(make-string (max 0 (- time-columns level)) ?|)
(if (eq formula '%)
(format "%.1f |" (* 100 (/ time (float total-time))))
(format "%.1f |" (* 100 (/ time (float total-time))))
"")
"\n")))))))
(delete-char -1)
@ -2836,7 +2944,7 @@ from the dynamic block definition."
(when (and contents (string-match "^\\([ \t]*#\\+tblfm:.*\\)" contents))
(setq recalc t)
(insert "\n" (match-string 1 contents))
(beginning-of-line 0))))
(forward-line -1))))
;; Insert specified formula line.
((stringp formula)
(insert "\n#+TBLFM: " formula)
@ -3018,8 +3126,9 @@ PROPERTIES: The list properties specified in the `:properties' parameter
(let* ((todo (org-get-todo-state))
(tags-list (org-get-tags))
(org-scanner-tags tags-list)
(org-trust-scanner-tags t))
(funcall matcher todo tags-list nil)))))
(org-trust-scanner-tags t)
(level (org-current-level)))
(funcall matcher todo tags-list level)))))
(goto-char (point-min))
(setq st t)
(while (or (and (bobp) (prog1 st (setq st nil))
@ -3079,7 +3188,7 @@ Otherwise, return nil."
(let ((origin (point))) ;; `save-excursion' may not work when deleting.
(prog1
(save-excursion
(beginning-of-line 1)
(forward-line 0)
(skip-chars-forward " \t")
(when (looking-at org-clock-string)
(let ((re (concat "[ \t]*" org-clock-string

243
lisp/org/org-colview.el
View file

@ -37,13 +37,13 @@
(declare-function org-agenda-redo "org-agenda" (&optional all))
(declare-function org-agenda-do-context-action "org-agenda" ())
(declare-function org-clock-sum-today "org-clock" (&optional headline-filter))
(declare-function org-element-extract-element "org-element" (element))
(declare-function org-element-extract "org-element-ast" (node))
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-restriction "org-element" (element))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-dynamic-block-define "org" (type func))
(declare-function org-link-display-format "ol" (s))
(declare-function org-link-open-from-string "ol" (s &optional arg))
@ -59,6 +59,19 @@
;;; Configuration
(defcustom org-columns-checkbox-allowed-values '("[ ]" "[X]")
"Allowed values for columns with SUMMARY-TYPE that uses checkbox.
The affected summary types are \"X%\", \"X/\", and \"X\" (see info
node `(org)Column attributes')."
:group 'org-properties
:package-version '(Org . "9.6")
:type '(repeat (choice
(const :tag "Unchecked [ ]" "[ ]")
(const :tag "Checked [X]" "[X]")
(const :tag "No checkbox" "")
(const :tag "Intermediate state [-]" "[-]")
(string :tag "Arbitrary string"))))
(defcustom org-columns-modify-value-for-display-function nil
"Function that modifies values for display in column view.
For example, it can be used to cut out a certain part from a time stamp.
@ -110,6 +123,12 @@ in `org-columns-summary-types-default', which see."
(function :tag "Summarize")
(function :tag "Collect")))))
(defcustom org-columns-dblock-formatter #'org-columns-dblock-write-default
"Function to format data in column view dynamic blocks.
For more information, see `org-columns-dblock-write-default'."
:group 'org-properties
:package-version '(Org . "9.7")
:type 'function)
;;; Column View
@ -118,6 +137,9 @@ in `org-columns-summary-types-default', which see."
"Holds the list of current column overlays.")
(put 'org-columns-overlays 'permanent-local t)
(defvar-local org-columns-global nil
"Local variable, holds non-nil when current columns are global.")
(defvar-local org-columns-current-fmt nil
"Local variable, holds the currently active column format.")
@ -180,28 +202,10 @@ See `org-columns-summary-types' for details.")
(org-defkey org-columns-map "\M-b" #'backward-char)
(org-defkey org-columns-map "a" #'org-columns-edit-allowed)
(org-defkey org-columns-map "s" #'org-columns-edit-attributes)
(org-defkey org-columns-map "\M-f"
(lambda () (interactive) (goto-char (1+ (point)))))
(org-defkey org-columns-map [right]
(lambda () (interactive) (goto-char (1+ (point)))))
(org-defkey org-columns-map [down]
(lambda () (interactive)
(let ((col (current-column)))
(beginning-of-line 2)
(while (and (org-invisible-p2) (not (eobp)))
(beginning-of-line 2))
(move-to-column col)
(if (derived-mode-p 'org-agenda-mode)
(org-agenda-do-context-action)))))
(org-defkey org-columns-map [up]
(lambda () (interactive)
(let ((col (current-column)))
(beginning-of-line 0)
(while (and (org-invisible-p2) (not (bobp)))
(beginning-of-line 0))
(move-to-column col)
(if (eq major-mode 'org-agenda-mode)
(org-agenda-do-context-action)))))
(org-defkey org-columns-map "\M-f" #'forward-char)
(org-defkey org-columns-map [right] #'forward-char)
(org-defkey org-columns-map [up] #'org-columns-move-up)
(org-defkey org-columns-map [down] #'org-columns-move-down)
(org-defkey org-columns-map [(shift right)] #'org-columns-next-allowed-value)
(org-defkey org-columns-map "n" #'org-columns-next-allowed-value)
(org-defkey org-columns-map [(shift left)] #'org-columns-previous-allowed-value)
@ -210,6 +214,8 @@ See `org-columns-summary-types' for details.")
(org-defkey org-columns-map ">" #'org-columns-widen)
(org-defkey org-columns-map [(meta right)] #'org-columns-move-right)
(org-defkey org-columns-map [(meta left)] #'org-columns-move-left)
(org-defkey org-columns-map [(meta down)] #'org-columns-move-row-down)
(org-defkey org-columns-map [(meta up)] #'org-columns-move-row-up)
(org-defkey org-columns-map [(shift meta right)] #'org-columns-new)
(org-defkey org-columns-map [(shift meta left)] #'org-columns-delete)
(dotimes (i 10)
@ -231,6 +237,8 @@ See `org-columns-summary-types' for details.")
"--"
["Move column right" org-columns-move-right t]
["Move column left" org-columns-move-left t]
["Move row up" org-columns-move-row-up t]
["Move row down" org-columns-move-row-down t]
["Add column" org-columns-new t]
["Delete column" org-columns-delete t]
"--"
@ -376,17 +384,19 @@ ORIGINAL is the real string, i.e., before it is modified by
"Store the relative remapping of column header-line.
This is needed to later remove this relative remapping.")
(defvar org-columns--read-only-string nil)
(defun org-columns--display-here (columns &optional dateline)
"Overlay the current line with column display.
COLUMNS is an alist (SPEC VALUE DISPLAYED). Optional argument
DATELINE is non-nil when the face used should be
`org-agenda-column-dateline'."
(when (and (ignore-errors (require 'face-remap))
org-columns-header-line-remap)
(when (and (not org-columns-header-line-remap)
(or (fboundp 'face-remap-add-relative)
(ignore-errors (require 'face-remap))))
(setq org-columns-header-line-remap
(face-remap-add-relative 'header-line '(:inherit default))))
(save-excursion
(beginning-of-line)
(forward-line 0)
(let* ((level-face (and (looking-at "\\(\\**\\)\\(\\* \\)")
(org-get-level-face 2)))
(ref-face (or level-face
@ -449,18 +459,36 @@ DATELINE is non-nil when the face used should be
(line-end-position 0)
(line-beginning-position 2)
'read-only
(substitute-command-keys
"Type \\<org-columns-map>`\\[org-columns-edit-value]' \
to edit property")))))))
(or org-columns--read-only-string
(setq org-columns--read-only-string
(substitute-command-keys
"Type \\<org-columns-map>`\\[org-columns-edit-value]' \
to edit property")))))))))
(defun org-columns--truncate-below-width (string width)
"Return a substring of STRING no wider than WIDTH.
This substring must start at 0, and must be the longest possible
substring whose `string-width' does not exceed WIDTH."
(declare (side-effect-free t))
(let ((end (min width (length string))) res)
(while (and end (>= end 0))
(let* ((curr (string-width (substring string 0 end)))
(excess (- curr width)))
(if (> excess 0)
(cl-decf end (max 1 (/ excess 2)))
(setq res (substring string 0 end) end nil))))
res))
(defun org-columns-add-ellipses (string width)
"Truncate STRING with WIDTH characters, with ellipses."
(cond
((<= (length string) width) string)
((<= width (length org-columns-ellipses))
(substring org-columns-ellipses 0 width))
(t (concat (substring string 0 (- width (length org-columns-ellipses)))
org-columns-ellipses))))
((<= (string-width string) width) string)
((<= width (string-width org-columns-ellipses))
(org-columns--truncate-below-width org-columns-ellipses width))
(t (concat
(org-columns--truncate-below-width
string (- width (string-width org-columns-ellipses)))
org-columns-ellipses))))
(defvar org-columns-full-header-line-format nil
"The full header line format, will be shifted by horizontal scrolling." )
@ -728,7 +756,7 @@ an integer, select that value."
(let ((all
(or (org-property-get-allowed-values pom key)
(pcase (nth column org-columns-current-fmt-compiled)
(`(,_ ,_ ,_ ,(or "X" "X/" "X%") ,_) '("[ ]" "[X]")))
(`(,_ ,_ ,_ ,(or "X" "X/" "X%") ,_) org-columns-checkbox-allowed-values))
(org-colview-construct-allowed-dates value))))
(if previous (reverse all) all))))
(when (equal key "ITEM") (error "Cannot edit item headline from here"))
@ -818,7 +846,7 @@ current specifications. This function also sets
(let ((case-fold-search t))
(while (re-search-forward "^[ \t]*#\\+COLUMNS: .+$" nil t)
(let ((element (org-element-at-point)))
(when (eq (org-element-type element) 'keyword)
(when (org-element-type-p element 'keyword)
(throw :found (org-element-property :value element)))))
nil)))
org-columns-default-format)))
@ -851,6 +879,7 @@ turn on column view for the whole buffer unconditionally.
When COLUMNS-FMT-STRING is non-nil, use it as the column format."
(interactive "P")
(org-columns-remove-overlays)
(setq-local org-columns-global global)
(save-excursion
(when global (goto-char (point-min)))
(if (markerp org-columns-begin-marker)
@ -873,7 +902,7 @@ When COLUMNS-FMT-STRING is non-nil, use it as the column format."
;; Collect contents of columns ahead of time so as to
;; compute their maximum width.
(org-scan-tags
(lambda () (cons (point) (org-columns--collect-values))) t org--matcher-tags-todo-only)))
(lambda () (cons (point-marker) (org-columns--collect-values))) t org--matcher-tags-todo-only)))
(when cache
(org-columns--set-widths cache)
(org-columns--display-here-title)
@ -971,6 +1000,30 @@ details."
(interactive "p")
(org-columns-widen (- arg)))
(defun org-columns-move-up ()
"In column view, move cursor up one row.
When in agenda column view, also call `org-agenda-do-context-action'."
(interactive)
(let ((col (current-column)))
(forward-line -1)
(while (and (org-invisible-p2) (not (bobp)))
(forward-line -1))
(move-to-column col)
(if (eq major-mode 'org-agenda-mode)
(org-agenda-do-context-action))))
(defun org-columns-move-down ()
"In column view, move cursor down one row.
When in agenda column view, also call `org-agenda-do-context-action'."
(interactive)
(let ((col (current-column)))
(forward-line 1)
(while (and (org-invisible-p2) (not (eobp)))
(forward-line 1))
(move-to-column col)
(if (derived-mode-p 'org-agenda-mode)
(org-agenda-do-context-action))))
(defun org-columns-move-right ()
"Swap this column with the one to the right."
(interactive)
@ -1005,6 +1058,27 @@ details."
(org-columns-move-right)
(backward-char 1)))
(defun org-columns--move-row (&optional up)
"Move the current table row down.
With non-nil optional argument UP, move it up."
(let ((inhibit-read-only t)
(col (current-column)))
(if up (org-move-subtree-up)
(org-move-subtree-down))
(let ((org-columns-inhibit-recalculation t))
(org-columns-redo)
(move-to-column col))))
(defun org-columns-move-row-down ()
"Move the current table row down."
(interactive)
(org-columns--move-row))
(defun org-columns-move-row-up ()
"Move the current table row up."
(interactive)
(org-columns--move-row 'up))
(defun org-columns-store-format ()
"Store the text version of the current columns format.
The format is stored either in the COLUMNS property of the node
@ -1022,7 +1096,7 @@ the current buffer."
(catch :found
(while (re-search-forward "^[ \t]*#\\+COLUMNS:\\(.*\\)" nil t)
(let ((element (save-match-data (org-element-at-point))))
(when (and (eq (org-element-type element) 'keyword)
(when (and (org-element-type-p element 'keyword)
(equal (org-element-property :key element)
"COLUMNS"))
(replace-match (concat " " fmt) t t nil 1)
@ -1072,7 +1146,7 @@ the current buffer."
(if (derived-mode-p 'org-mode)
;; Since we already know the columns format, provide it
;; instead of computing again.
(call-interactively #'org-columns org-columns-current-fmt)
(funcall-interactively #'org-columns org-columns-global org-columns-current-fmt)
(org-agenda-redo)
(call-interactively #'org-agenda-columns)))
(message "Recomputing columns...done")))
@ -1132,7 +1206,7 @@ This function updates `org-columns-current-fmt-compiled'."
(defun org-columns--age-to-minutes (s)
"Turn age string S into a number of minutes.
An age is either computed from a given time-stamp, or indicated
An age is either computed from a given timestamp, or indicated
as a canonical duration, i.e., using units defined in
`org-duration-canonical-units'."
(cond
@ -1161,8 +1235,8 @@ Return the result as a duration."
SPEC is a column format specification. When optional argument
UPDATE is non-nil, summarized values can replace existing ones in
properties drawers."
(let* ((lmax (if (bound-and-true-p org-inlinetask-min-level)
org-inlinetask-min-level
(let* ((lmax (if (bound-and-true-p org-inlinetask-max-level)
org-inlinetask-max-level
29)) ;Hard-code deepest level.
(lvals (make-vector (1+ lmax) nil))
(level 0)
@ -1198,9 +1272,9 @@ properties drawers."
;; property `org-summaries', in alist whose key is SPEC.
(let* ((summary
(and summarize
(let ((values (append (and (/= last-level inminlevel)
(aref lvals last-level))
(aref lvals inminlevel))))
(let ((values
(cl-loop for l from (1+ level) to lmax
append (aref lvals l))))
(and values (funcall summarize values printf))))))
;; Leaf values are not summaries: do not mark them.
(when summary
@ -1374,9 +1448,13 @@ that will be excluded from the resulting view. FORMAT is a
format string for columns, or nil. When LOCAL is non-nil, only
capture headings in current subtree.
This function returns a list containing the title row and all
other rows. Each row is a list of fields, as strings, or
`hline'."
This function returns a list containing the title row and all other
rows. Each row is either a list, or the symbol `hline'. The first list
is the heading row as a list of strings with the column titles according
to FORMAT. All subsequent lists each represent a body row as a list
whose first element is an integer indicating the outline level of the
entry, and whose remaining elements are strings with the contents for
the columns according to FORMAT."
(org-columns (not local) format)
(goto-char org-columns-top-level-marker)
(let ((columns (length org-columns-current-fmt-compiled))
@ -1389,11 +1467,10 @@ other rows. Each row is a list of fields, as strings, or
(dotimes (i columns)
(let* ((col (+ (line-beginning-position) i))
(p (get-char-property col 'org-columns-key)))
(push (org-quote-vert
(get-char-property col
(if (string= p "ITEM")
'org-columns-value
'org-columns-value-modified)))
(push (get-char-property col
(if (string= p "ITEM")
'org-columns-value
'org-columns-value-modified))
row)))
(unless (or
(and skip-empty
@ -1424,8 +1501,10 @@ an inline src-block."
(org-element-map data
'(footnote-reference inline-babel-call inline-src-block target
radio-target statistics-cookie)
#'org-element-extract-element)
(org-no-properties (org-element-interpret-data data))))
#'org-element-extract)
(org-quote-vert
(org-no-properties
(org-element-interpret-data data)))))
;;;###autoload
(defun org-dblock-write:columnview (params)
@ -1477,7 +1556,17 @@ PARAMS is a property list of parameters:
`:vlines'
When non-nil, make each column a column group to enforce
vertical lines."
vertical lines.
`:link'
Link the item headlines in the table to their origins.
`:formatter'
A function to format the data and insert it into the
buffer. Overrides the default formatting function set in
`org-columns-dblock-formatter'."
(let ((table
(let ((id (plist-get params :id))
view-file view-pos)
@ -1495,7 +1584,7 @@ PARAMS is a property list of parameters:
(setq view-file filename)
(setq view-pos position))
(_ (user-error "Cannot find entry with :ID: %s" id)))
(with-current-buffer (if view-file (get-file-buffer view-file)
(with-current-buffer (if view-file (org-get-agenda-file-buffer view-file)
(current-buffer))
(org-with-wide-buffer
(when view-pos (goto-char view-pos))
@ -1504,7 +1593,21 @@ PARAMS is a property list of parameters:
(plist-get params :skip-empty-rows)
(plist-get params :exclude-tags)
(plist-get params :format)
view-pos))))))
view-pos)))))
(formatter (or (plist-get params :formatter)
org-columns-dblock-formatter
#'org-columns-dblock-write-default)))
(funcall formatter (point) table params)))
(defun org-columns-dblock-write-default (ipos table params)
"Write out a columnview table at position IPOS in the current buffer.
TABLE is a table with data as produced by `org-columns--capture-view'.
PARAMS is the parameter property list obtained from the dynamic block
definition."
(let ((link (plist-get params :link))
(width-specs
(mapcar (lambda (spec) (nth 2 spec))
org-columns-current-fmt-compiled)))
(when table
;; Prune level information from the table. Also normalize
;; headings: remove stars, add indentation entities, if
@ -1528,7 +1631,14 @@ PARAMS is a property list of parameters:
(and (numberp hlines) (<= level hlines))))
(push 'hline new-table))
(when item-index
(let ((item (org-columns--clean-item (nth item-index (cdr row)))))
(let* ((raw (nth item-index (cdr row)))
(cleaned (org-columns--clean-item raw))
(item (if (not link) cleaned
(let ((search (org-link-heading-search-string raw)))
(org-link-make-string
(if (not (buffer-file-name)) search
(format "file:%s::%s" (buffer-file-name) search))
cleaned)))))
(setf (nth item-index (cdr row))
(if (and indent (> level 1))
(concat "\\_" (make-string (* 2 (1- level)) ?\s) item)
@ -1540,6 +1650,13 @@ PARAMS is a property list of parameters:
(append (mapcar (lambda (x) (if (eq 'hline x) x (cons "" x)))
table)
(list (cons "/" (make-list size "<>")))))))
(when (seq-find #'identity width-specs)
;; There are width specifiers in column format. Pass them
;; to the resulting table, adding alignment field as the first
;; row.
(push (mapcar (lambda (width) (when width (format "<%d>" width))) width-specs) table))
;; now insert the table into the buffer
(goto-char ipos)
(let ((content-lines (org-split-string (plist-get params :content) "\n"))
recalc)
;; Insert affiliated keywords before the table.
@ -1561,7 +1678,9 @@ PARAMS is a property list of parameters:
(insert "\n" line)
(unless recalc (setq recalc t))))))
(when recalc (org-table-recalculate 'all t))
(org-table-align)))))
(org-table-align)
(when (seq-find #'identity width-specs)
(org-table-shrink))))))
;;;###autoload
(defun org-columns-insert-dblock ()

236
lisp/org/org-compat.el
View file

@ -52,9 +52,15 @@
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-at-point-no-context "org-element" (&optional pom))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-lineage "org-element" (blob &optional types with-self))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-lineage "org-element-ast" (blob &optional types with-self))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-contents-begin "org-element" (node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading))
(declare-function org-get-heading "org" (&optional no-tags no-todo no-priority no-comment))
(declare-function org-get-tags "org" (&optional pos local))
@ -71,6 +77,7 @@
(declare-function outline-next-heading "outline" ())
(declare-function speedbar-line-directory "speedbar" (&optional depth))
(declare-function table--at-cell-p "table" (position &optional object at-column))
(declare-function ob-clojure-eval-with-cmd "ob-clojure" (cmd expanded))
(declare-function org-fold-folded-p "org-fold" (&optional pos spec-or-alias))
(declare-function org-fold-hide-sublevels "org-fold" (levels))
(declare-function org-fold-hide-subtree "org-fold" ())
@ -96,6 +103,25 @@
;;; Emacs < 29 compatibility
(if (fboundp 'display-buffer-full-frame)
(defalias 'org-display-buffer-full-frame #'display-buffer-full-frame)
(defun org-display-buffer-full-frame (buffer alist)
"Display BUFFER in the current frame, taking the entire frame.
ALIST is an association list of action symbols and values. See
Info node `(elisp) Buffer Display Action Alists' for details of
such alists.
This is an action function for buffer display, see Info
node `(elisp) Buffer Display Action Functions'. It should be
called only by `display-buffer' or a function directly or
indirectly called by the latter."
(when-let ((window (or (display-buffer-reuse-window buffer alist)
(display-buffer-same-window buffer alist)
(display-buffer-pop-up-window buffer alist)
(display-buffer-use-some-window buffer alist))))
(delete-other-windows window)
window)))
(defvar org-file-has-changed-p--hash-table (make-hash-table :test #'equal)
"Internal variable used by `org-file-has-changed-p'.")
@ -130,9 +156,41 @@ Upper-case and lower-case letters are treated as equal.
Unibyte strings are converted to multibyte for comparison."
(eq t (compare-strings string1 0 nil string2 0 nil t))))
(defun org-buffer-text-pixel-width ()
"Return pixel width of text in current buffer.
This function uses `buffer-text-pixel-size', when available, and falls
back to `window-text-pixel-size' otherwise."
(if (fboundp 'buffer-text-pixel-size)
(car (buffer-text-pixel-size nil nil t))
(if (get-buffer-window (current-buffer))
;; FIXME: 10000 because `most-positive-fixnum' ain't working
;; (tests failing) and this call will be removed after we drop
;; Emacs 28 support anyway.
(car (window-text-pixel-size
nil (point-min) (point-max) 10000))
(let ((dedicatedp (window-dedicated-p))
(oldbuffer (window-buffer)))
(unwind-protect
(progn
;; Do not throw error in dedicated windows.
(set-window-dedicated-p nil nil)
(set-window-buffer nil (current-buffer))
(car (window-text-pixel-size
nil (point-min) (point-max) 10000)))
(set-window-buffer nil oldbuffer)
(set-window-dedicated-p nil dedicatedp))))))
;;; Emacs < 28.1 compatibility
(if (= 2 (cdr (subr-arity (symbol-function 'get-buffer-create))))
;; Emacs >27.
(defalias 'org-get-buffer-create #'get-buffer-create)
(defun org-get-buffer-create (buffer-or-name &optional _)
"Call `get-buffer-create' with BUFFER-OR-NAME argument.
Ignore optional argument."
(get-buffer-create buffer-or-name)))
(if (fboundp 'file-name-concat)
(defalias 'org-file-name-concat #'file-name-concat)
(defun org-file-name-concat (directory &rest components)
@ -204,6 +262,25 @@ removed."
`(progn ,@body))
(defalias 'org-combine-change-calls 'combine-change-calls))
;; `flatten-tree' was added in Emacs 27.1.
(if (fboundp 'flatten-tree)
(defalias 'org--flatten-tree #'flatten-tree)
;; The implementation is taken from Emacs subr.el 8664ba18c7c5.
(defun org--flatten-tree (tree)
"Return a \"flattened\" copy of TREE.
A `flatten-tree' polyfill for compatibility with Emacs versions
older than 27.1"
(let (elems)
(while (consp tree)
(let ((elem (pop tree)))
(while (consp elem)
(push (cdr elem) tree)
(setq elem (car elem)))
(if elem (push elem elems))))
(if tree (push tree elems))
(nreverse elems))))
(if (version< emacs-version "27.1")
(defsubst org-replace-buffer-contents (source &optional _max-secs _max-costs)
(replace-buffer-contents source))
@ -290,6 +367,24 @@ Execute BODY, and unwind connection-local variables."
`(with-connection-local-profiles (connection-local-get-profiles nil)
,@body)))
;; assoc-delete-all missing from 26.1
(if (fboundp 'assoc-delete-all)
(defalias 'org-assoc-delete-all 'assoc-delete-all)
;; from compat/compat-27.el
(defun org-assoc-delete-all (key alist &optional test)
"Delete all matching key from alist, default test equal"
(unless test (setq test #'equal))
(while (and (consp (car alist))
(funcall test (caar alist) key))
(setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr))
(funcall test (caar tail-cdr) key))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
alist))
;;; Emacs < 26.1 compatibility
@ -386,6 +481,10 @@ Counting starts at 1."
(define-obsolete-function-alias 'org-string-match-p 'string-match-p "9.0")
;;;; Functions and variables from previous releases now obsolete.
(define-obsolete-variable-alias 'org-export-ignored-local-variables
'org-element-ignored-local-variables "Org 9.7")
(define-obsolete-function-alias 'org-habit-get-priority
'org-habit-get-urgency "Org 9.7")
(define-obsolete-function-alias 'org-timestamp-format
'org-format-timestamp "Org 9.6")
(define-obsolete-variable-alias 'org-export-before-processing-hook
@ -411,7 +510,7 @@ Counting starts at 1."
'completing-read "9.0")
(define-obsolete-function-alias 'org-iread-file-name 'read-file-name "9.0")
(define-obsolete-function-alias 'org-days-to-time
'org-time-stamp-to-now "8.2")
'org-timestamp-to-now "8.2")
(define-obsolete-variable-alias 'org-agenda-ignore-drawer-properties
'org-agenda-ignore-properties "9.0")
(define-obsolete-function-alias 'org-preview-latex-fragment
@ -549,10 +648,51 @@ Counting starts at 1."
(define-obsolete-function-alias 'org-file-url-p 'org-url-p "9.6")
(define-obsolete-variable-alias 'org-plantuml-executable-args 'org-plantuml-args
"Org 9.6")
(defvar org-cached-props nil)
(defvar org-use-property-inheritance)
(declare-function org-entry-get "org" (epom property &optional inherit literal-nil))
(declare-function org-entry-properties "org" (&optional epom which))
(defun org-cached-entry-get (pom property)
(if (or (eq t org-use-property-inheritance)
(and (stringp org-use-property-inheritance)
(let ((case-fold-search t))
(string-match-p org-use-property-inheritance property)))
(and (listp org-use-property-inheritance)
(member-ignore-case property org-use-property-inheritance)))
;; Caching is not possible, check it directly.
(org-entry-get pom property 'inherit)
;; Get all properties, so we can do complicated checks easily.
(cdr (assoc-string property
(or org-cached-props
(setq org-cached-props (org-entry-properties pom)))
t))))
(make-obsolete 'org-cached-entry-get
"Performs badly. Instead use `org-entry-get' with the argument INHERIT set to `selective'"
"9.7")
(defconst org-latex-line-break-safe "\\\\[0pt]"
"Linebreak protecting the following [...].
Without \"[0pt]\" it would be interpreted as an optional argument to
the \\\\.
This constant, for example, makes the below code not err:
\\begin{tabular}{c|c}
[t] & s\\\\[0pt]
[I] & A\\\\[0pt]
[m] & kg
\\end{tabular}")
(make-obsolete 'org-latex-line-break-safe
"should not be used - it is not safe in all the scenarios."
"9.7")
(defun org-in-fixed-width-region-p ()
"Non-nil if point in a fixed-width region."
(save-match-data
(eq 'fixed-width (org-element-type (org-element-at-point)))))
(org-element-type-p (org-element-at-point) 'fixed-width)))
(make-obsolete 'org-in-fixed-width-region-p
"use `org-element' library"
"9.0")
@ -570,6 +710,26 @@ Counting starts at 1."
(make-obsolete 'org-let "to be removed" "9.6")
(make-obsolete 'org-let2 "to be removed" "9.6")
(define-obsolete-function-alias 'org--math-always-on
'org--math-p "9.7")
(defmacro org-no-popups (&rest body)
"Suppress popup windows and evaluate BODY."
`(let (pop-up-frames pop-up-windows)
,@body))
(make-obsolete 'org-no-popups "no longer used" "9.7")
(defun org-switch-to-buffer-other-window (&rest args)
"Switch to buffer in a second window on the current frame.
In particular, do not allow pop-up frames.
Returns the newly created buffer."
(let (pop-up-frames pop-up-windows)
(apply #'switch-to-buffer-other-window args)))
(make-obsolete 'org-switch-to-buffer-other-window "no longer used" "9.7")
(make-obsolete 'org-refresh-category-properties "no longer used" "9.7")
(make-obsolete 'org-refresh-effort-properties "no longer used" "9.7")
(defun org-compatible-face (inherits specs)
"Make a compatible face specification.
If INHERITS is an existing face and if the Emacs version supports
@ -616,7 +776,7 @@ See `org-link-parameters' for documentation on the other parameters."
(defun org-table-recognize-table.el ()
"If there is a table.el table nearby, recognize it and move into it."
(when (org-at-table.el-p)
(beginning-of-line)
(forward-line 0)
(unless (or (looking-at org-table-dataline-regexp)
(not (looking-at org-table1-hline-regexp)))
(forward-line)
@ -658,13 +818,23 @@ See `org-link-parameters' for documentation on the other parameters."
(org-unbracket-string "<" ">" s))
(make-obsolete 'org-remove-angle-brackets 'org-unbracket-string "9.0")
(defcustom org-capture-bookmark t
"When non-nil, add bookmark pointing at the last stored position when capturing."
:group 'org-capture
:version "24.3"
:type 'boolean)
(make-obsolete-variable
'org-capture-bookmark
"use `org-bookmark-names-plist' instead."
"9.7")
(defcustom org-publish-sitemap-file-entry-format "%t"
"Format string for site-map file entry.
You could use brackets to delimit on what part the link will be.
%t is the title.
%a is the author.
%d is the date formatted using `org-publish-sitemap-date-format'."
%d is the date."
:group 'org-export-publish
:type 'string)
(make-obsolete-variable
@ -881,21 +1051,21 @@ When optional argument ELEMENT is a parsed drawer, as returned by
When buffer positions BEG and END are provided, hide or show that
region as a drawer without further ado."
(declare (obsolete "use `org-hide-drawer-toggle' instead." "9.4"))
(if (and beg end) (org-fold-region beg end flag (if (eq org-fold-core-style 'text-properties) 'drawer 'outline))
(if (and beg end) (org-fold-region beg end flag 'drawer)
(let ((drawer
(or element
(and (save-excursion
(beginning-of-line)
(forward-line 0)
(looking-at-p "^[ \t]*:\\(\\(?:\\w\\|[-_]\\)+\\):[ \t]*$"))
(org-element-at-point)))))
(when (memq (org-element-type drawer) '(drawer property-drawer))
(let ((post (org-element-property :post-affiliated drawer)))
(when (org-element-type-p drawer '(drawer property-drawer))
(let ((post (org-element-post-affiliated drawer)))
(org-fold-region
(save-excursion (goto-char post) (line-end-position))
(save-excursion (goto-char (org-element-property :end drawer))
(save-excursion (goto-char (org-element-end drawer))
(skip-chars-backward " \t\n")
(line-end-position))
flag (if (eq org-fold-core-style 'text-properties) 'drawer 'outline))
flag 'drawer)
;; When the drawer is hidden away, make sure point lies in
;; a visible part of the buffer.
(when (invisible-p (max (1- (point)) (point-min)))
@ -919,7 +1089,7 @@ an error. Return a non-nil value when toggling is successful."
(goto-char start)
(while (and (< (point) end)
(re-search-forward "^[ \t]*#\\+begin_?\
\\([^ \n]+\\)\\(\\([^\n]+\\)\\)?\n\\([^\000]+?\\)#\\+end_?\\1[ \t]*$" end t))
\\([^ \n]+\\)\\(\\([^\n]+\\)\\)?\n\\(\\(?:.\\|\n\\)+?\\)#\\+end_?\\1[ \t]*$" end t))
(save-excursion
(save-match-data
(goto-char (match-beginning 0))
@ -1116,6 +1286,26 @@ context. See the individual commands for more information."
(make-obsolete-variable 'org-latex-polyglossia-language-alist
"set `org-latex-language-alist' instead." "9.6")
(defconst org-babel-python-mode 'python
"Python mode for use in running python interactively.")
(make-obsolete-variable
'org-babel-python-mode
"Only the built-in Python mode is supported in ob-python now."
"9.7")
(define-obsolete-function-alias 'ob-clojure-eval-with-babashka
#'ob-clojure-eval-with-cmd "9.7")
(define-obsolete-function-alias 'org-export-get-parent
'org-element-parent "9.7")
(define-obsolete-function-alias 'org-export-get-parent-element
'org-element-parent-element "9.7")
(define-obsolete-function-alias 'org-print-speed-command
'org--print-speed-command "9.7"
"Internal function. Subject of unannounced changes.")
;;;; Obsolete link types
(eval-after-load 'ol
@ -1366,7 +1556,7 @@ ELEMENT is the element at point."
;; Only in inline footnotes, within the definition.
(and (eq (org-element-property :type object) 'inline)
(< (save-excursion
(goto-char (org-element-property :begin object))
(goto-char (org-element-begin object))
(search-forward ":" nil t 2))
(point))))
(otherwise t))))
@ -1375,7 +1565,7 @@ ELEMENT is the element at point."
"Function used for `flyspell-generic-check-word-predicate'."
(if (org-at-heading-p)
;; At a headline or an inlinetask, check title only.
(and (save-excursion (beginning-of-line)
(and (save-excursion (forward-line 0)
(and (let ((case-fold-search t))
(not (looking-at-p "\\*+ END[ \t]*$")))
(let ((case-fold-search nil))
@ -1387,19 +1577,19 @@ ELEMENT is the element at point."
;; Ignore checks in code, verbatim and others.
(org--flyspell-object-check-p (org-element-at-point-no-context)))
(let* ((element (org-element-at-point-no-context))
(post-affiliated (org-element-property :post-affiliated element)))
(post-affiliated (org-element-post-affiliated element)))
(cond
;; Ignore checks in all affiliated keywords but captions.
((< (point) post-affiliated)
(and (save-excursion
(beginning-of-line)
(forward-line 0)
(let ((case-fold-search t)) (looking-at "[ \t]*#\\+CAPTION:")))
(> (point) (match-end 0))
(org--flyspell-object-check-p element)))
;; Ignore checks in LOGBOOK (or equivalent) drawer.
((let ((log (org-log-into-drawer)))
(and log
(let ((drawer (org-element-lineage element '(drawer))))
(let ((drawer (org-element-lineage element 'drawer)))
(and drawer
(org-string-equal-ignore-case
log (org-element-property :drawer-name drawer))))))
@ -1413,7 +1603,7 @@ ELEMENT is the element at point."
(save-excursion
(end-of-line)
(skip-chars-forward " \r\t\n")
(< (point) (org-element-property :end element)))))
(< (point) (org-element-end element)))))
;; Arbitrary list of keywords where checks are meaningful.
;; Make sure point is on the value part of the element.
(keyword
@ -1425,8 +1615,8 @@ ELEMENT is the element at point."
;; table rows (after affiliated keywords) but some objects
;; must not be affected.
((paragraph table-row verse-block)
(let ((cbeg (org-element-property :contents-begin element))
(cend (org-element-property :contents-end element)))
(let ((cbeg (org-element-contents-begin element))
(cend (org-element-contents-end element)))
(and cbeg (>= (point) cbeg) (< (point) cend)
(org--flyspell-object-check-p element))))))))))
(put 'org-mode 'flyspell-mode-predicate 'org-mode-flyspell-verify)
@ -1561,7 +1751,7 @@ key."
"Run `org-back-to-heading' when in org-mode."
(if (derived-mode-p 'org-mode)
(progn
(beginning-of-line)
(forward-line 0)
(or (org-at-heading-p (not invisible-ok))
(let (found)
(save-excursion

62
lisp/org/org-crypt.el
View file

@ -71,16 +71,18 @@
(defvar epg-context)
(declare-function org-back-over-empty-lines "org" ())
(declare-function org-current-level "org" ())
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-before-first-heading-p "org" ())
(declare-function org-end-of-meta-data "org" (&optional full))
(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading))
(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading element))
(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
(declare-function org-fold-subtree "org-fold" (flag))
(declare-function org-make-tags-matcher "org" (match))
(declare-function org-make-tags-matcher "org" (match &optional only-local-tags))
(declare-function org-previous-visible-heading "org" (arg))
(declare-function org-scan-tags "org" (action matcher todo-only &optional start-level))
(declare-function org-set-property "org" (property value))
(declare-function org-cycle-set-startup-visibility "org-cycle" ())
(defgroup org-crypt nil
"Org Crypt."
@ -113,16 +115,16 @@ This setting can be overridden in the CRYPTKEY property."
(defcustom org-crypt-disable-auto-save 'ask
"What org-decrypt should do if `auto-save-mode' is enabled.
t : Disable auto-save-mode for the current buffer
t : Disable `auto-save-mode' for the current buffer
prior to decrypting an entry.
nil : Leave auto-save-mode enabled.
nil : Leave `auto-save-mode' enabled.
This may cause data to be written to disk unencrypted!
`ask' : Ask user whether or not to disable auto-save-mode
`ask' : Ask user whether or not to disable `auto-save-mode'
for the current buffer.
`encrypt': Leave auto-save-mode enabled for the current buffer,
`encrypt': Leave `auto-save-mode' enabled for the current buffer,
but automatically re-encrypt all decrypted entries
*before* auto-saving.
NOTE: This only works for entries which have a tag
@ -165,7 +167,7 @@ and END are buffer positions delimiting the encrypted area."
(cons start (line-beginning-position 2)))))))))
(defun org-crypt-check-auto-save ()
"Check whether auto-save-mode is enabled for the current buffer.
"Check whether `auto-save-mode' is enabled for the current buffer.
`auto-save-mode' may cause leakage when decrypting entries, so
check whether it's enabled, and decide what to do about it.
@ -177,7 +179,7 @@ See `org-crypt-disable-auto-save'."
(eq org-crypt-disable-auto-save t)
(and
(eq org-crypt-disable-auto-save 'ask)
(y-or-n-p "org-decrypt: auto-save-mode may cause leakage. Disable it for current buffer? ")))
(y-or-n-p "`org-decrypt': auto-save-mode may cause leakage. Disable it for current buffer? ")))
(message "org-decrypt: Disabling auto-save-mode for %s"
(or (buffer-file-name) (current-buffer)))
;; The argument to auto-save-mode has to be "-1", since
@ -244,12 +246,13 @@ Assume `epg-context' is set."
;; contents in the buffer.
(error
(insert contents)
(error (error-message-string err)))))
(error "%s" (error-message-string err)))))
(when folded-heading
(goto-char folded-heading)
(org-fold-subtree t))
nil)))))
(defvar org-outline-regexp-bol)
;;;###autoload
(defun org-decrypt-entry ()
"Decrypt the content of the current headline."
@ -265,23 +268,44 @@ Assume `epg-context' is set."
(save-excursion
(org-previous-visible-heading 1)
(point))))
(level (org-current-level))
(encrypted-text (org-crypt--encrypted-text beg end))
(decrypted-text
(decode-coding-string
(epg-decrypt-string epg-context encrypted-text)
'utf-8)))
'utf-8))
origin-marker)
;; Delete region starting just before point, because the
;; outline property starts at the \n of the heading.
(delete-region (1- (point)) end)
;; Store a checksum of the decrypted and the encrypted text
;; value. This allows reusing the same encrypted text if the
;; text does not change, and therefore avoid a re-encryption
;; process.
(insert "\n"
(propertize decrypted-text
'org-crypt-checksum (sha1 decrypted-text)
'org-crypt-key (org-crypt-key-for-heading)
'org-crypt-text encrypted-text))
(setq origin-marker (point-marker))
(if (string-match (org-headline-re level) decrypted-text)
;; If decrypted text contains other headings with levels
;; below LEVEL, adjust the subtree.
(let ((start 0) (min-level level))
(while (string-match (org-headline-re level) decrypted-text start)
(setq min-level (min min-level (1- (length (match-string 0 decrypted-text))))
start (match-end 0)))
(insert "\n"
(replace-regexp-in-string
org-outline-regexp-bol
(concat (make-string (1+ (- level min-level)) ?*) "\\&")
decrypted-text)))
;; Store a checksum of the decrypted and the encrypted text
;; value. This allows reusing the same encrypted text if the
;; text does not change, and therefore avoid a re-encryption
;; process.
(insert "\n"
(propertize decrypted-text
'org-crypt-checksum (sha1 decrypted-text)
'org-crypt-key (org-crypt-key-for-heading)
'org-crypt-text encrypted-text)))
;; Apply initial visibility.
(save-restriction
(narrow-to-region origin-marker (point))
(set-marker origin-marker nil)
(org-cycle-set-startup-visibility))
;; ... but keep the previous folded state.
(when folded-heading
(goto-char folded-heading)
(org-fold-subtree t))

109
lisp/org/org-ctags.el
View file

@ -28,7 +28,7 @@
;;
;; Allows Org mode to make use of the Emacs `etags' system. Defines
;; tag destinations in Org files as any text between <<double angled
;; brackets>>. This allows the tags-generation program `exuberant
;; brackets>>. This allows the tags-generation program `exuberant
;; ctags' to parse these files and create tag tables that record where
;; these destinations are found. Plain [[links]] in org mode files
;; which do not have <<matching destinations>> within the same file
@ -57,6 +57,12 @@
;; (add-hook 'org-mode-hook
;; (lambda ()
;; (define-key org-mode-map "\C-co" 'org-ctags-find-tag-interactive)))
;; (with-eval-after-load "org-ctags"
;; (org-ctags-enable))
;;
;; To activate the library, you need to call `org-ctags-enable' explicitly.
;; It used to be invoked during library loading, but it was against Emacs
;; policy and caused inconvenience of Org users who do not use `org-ctags'.
;;
;; By default, with org-ctags loaded, org will first try and visit the tag
;; with the same name as the link; then, if unsuccessful, ask the user if
@ -66,7 +72,7 @@
;; search the entire text of the current buffer for 'tag'.
;;
;; This behavior can be modified by changing the value of
;; ORG-CTAGS-OPEN-LINK-FUNCTIONS. For example I have the following in my
;; ORG-CTAGS-OPEN-LINK-FUNCTIONS. For example, I have the following in my
;; .emacs, which describes the same behavior as the above paragraph with
;; one difference:
;;
@ -149,20 +155,36 @@
(defvar org-ctags-enabled-p t
"Activate ctags support in org mode?")
(defvar org-ctags-tag-regexp "/<<([^>]+)>>/\\1/d,definition/"
(defvar org-ctags-tag-regexp "/<<([^<>]+)>>/\\1/d,definition/"
"Regexp expression used by ctags external program.
The regexp matches tag destinations in Org files.
Format is: /REGEXP/TAGNAME/FLAGS,TAGTYPE/
See the ctags documentation for more information.")
(defcustom org-ctags-path-to-ctags
(if (executable-find "ctags-exuberant")
"ctags-exuberant"
ctags-program-name)
(cond ((executable-find "ctags-exuberant")
"ctags-exuberant")
((boundp 'ctags-program-name)
ctags-program-name)
(t "ctags")) ; Emacs < 30
"Name of the ctags executable file."
:version "24.1"
:type 'file)
(defconst org-ctags--open-link-functions-list
(list
#'org-ctags-find-tag
#'org-ctags-ask-rebuild-tags-file-then-find-tag
#'org-ctags-rebuild-tags-file-then-find-tag
#'org-ctags-ask-append-topic
#'org-ctags-append-topic
#'org-ctags-ask-visit-buffer-or-file
#'org-ctags-visit-buffer-or-file
#'org-ctags-fail-silently)
"Options for `org-open-link-functions'.
Ensure that the user option and `unload-feature'
use the same set of functions.")
(defcustom org-ctags-open-link-functions
'(org-ctags-find-tag
org-ctags-ask-rebuild-tags-file-then-find-tag
@ -170,14 +192,7 @@ See the ctags documentation for more information.")
"List of functions to be prepended to ORG-OPEN-LINK-FUNCTIONS by ORG-CTAGS."
:version "24.1"
:type 'hook
:options '(org-ctags-find-tag
org-ctags-ask-rebuild-tags-file-then-find-tag
org-ctags-rebuild-tags-file-then-find-tag
org-ctags-ask-append-topic
org-ctags-append-topic
org-ctags-ask-visit-buffer-or-file
org-ctags-visit-buffer-or-file
org-ctags-fail-silently))
:options org-ctags--open-link-functions-list)
(defvar org-ctags-tag-list nil
@ -193,21 +208,21 @@ The following patterns are replaced in the string:
:type 'string)
(add-hook 'org-mode-hook
(lambda ()
(when (and org-ctags-enabled-p
(buffer-file-name))
;; Make sure this file's directory is added to default
;; directories in which to search for tags.
(let ((tags-filename
(expand-file-name
(concat (file-name-directory (buffer-file-name))
"/TAGS"))))
(when (file-exists-p tags-filename)
(visit-tags-table tags-filename))))))
(defun org-ctags--visit-tags-table ()
"Load tags for current file.
A function for `org-mode-hook."
(when (and org-ctags-enabled-p
(buffer-file-name))
;; Make sure this file's directory is added to default
;; directories in which to search for tags.
(let ((tags-filename
(expand-file-name
(concat (file-name-directory (buffer-file-name))
"/TAGS"))))
(when (file-exists-p tags-filename)
(visit-tags-table tags-filename)))))
(advice-add 'visit-tags-table :after #'org--ctags-load-tag-list)
(defun org--ctags-load-tag-list (&rest _)
(when (and org-ctags-enabled-p tags-file-name)
(setq-local org-ctags-tag-list
@ -215,12 +230,28 @@ The following patterns are replaced in the string:
(defun org-ctags-enable ()
(add-hook 'org-mode-hook #'org-ctags--visit-tags-table)
(advice-add 'visit-tags-table :after #'org--ctags-load-tag-list)
(advice-add 'xref-find-definitions :before
#'org--ctags-set-org-mark-before-finding-tag)
(put 'org-mode 'find-tag-default-function 'org-ctags-find-tag-at-point)
(setq org-ctags-enabled-p t)
(dolist (fn org-ctags-open-link-functions)
(add-hook 'org-open-link-functions fn t)))
(defun org-ctags-unload-function ()
"Disable `org-ctags' library.
Called by `unload-feature'."
(put 'org-mode 'find-tag-default-function nil)
(advice-remove 'visit-tags-table #'org--ctags-load-tag-list)
(advice-remove 'xref-find-definitions
#'org--ctags-set-org-mark-before-finding-tag)
(dolist (fn org-ctags--open-link-functions-list)
(remove-hook 'org-open-link-functions fn nil)))
;;; General utility functions. ===============================================
;; These work outside org-ctags mode.
@ -296,8 +327,6 @@ The new topic will be titled NAME (or TITLE if supplied)."
;;;; Misc interoperability with etags system =================================
(advice-add 'xref-find-definitions :before
#'org--ctags-set-org-mark-before-finding-tag)
(defun org--ctags-set-org-mark-before-finding-tag (&rest _)
"Before trying to find a tag, save our current position on org mark ring."
(save-excursion
@ -479,18 +508,21 @@ function may take several seconds to finish if the directory or
its subdirectories contain large numbers of taggable files."
(interactive)
(cl-assert (buffer-file-name))
(let ((dir-name (or directory-name
(file-name-directory (buffer-file-name))))
(let ((dir-name (shell-quote-argument
(expand-file-name
(if directory-name
(file-name-as-directory directory-name)
(file-name-directory (buffer-file-name))))))
(exitcode nil))
(save-excursion
(setq exitcode
(shell-command
(format (concat "%s --langdef=orgmode --langmap=orgmode:.org "
"--regex-orgmode=\"%s\" -f \"%s\" -e -R \"%s\"")
"--regex-orgmode=%s -f %sTAGS -e -R %s*")
org-ctags-path-to-ctags
org-ctags-tag-regexp
(expand-file-name (concat dir-name "/TAGS"))
(expand-file-name (concat dir-name "/*")))))
(shell-quote-argument org-ctags-tag-regexp)
dir-name
dir-name)))
(cond
((eql 0 exitcode)
(setq-local org-ctags-tag-list
@ -508,12 +540,11 @@ its subdirectories contain large numbers of taggable files."
(defun org-ctags-find-tag-interactive ()
"Prompt for the name of a tag, with autocompletion, then visit the named tag.
Uses `ido-mode' if available.
If the user enters a string that does not match an existing tag, create
a new topic."
(interactive)
(let* ((tag (ido-completing-read "Topic: " org-ctags-tag-list
nil 'confirm nil 'org-ctags-find-tag-history)))
(let* ((tag (completing-read "Topic: " org-ctags-tag-list
nil 'confirm nil 'org-ctags-find-tag-history)))
(when tag
(cond
((member tag org-ctags-tag-list)
@ -526,8 +557,6 @@ a new topic."
'org-open-link-functions tag))))))
(org-ctags-enable)
(provide 'org-ctags)
;;; org-ctags.el ends here

73
lisp/org/org-cycle.el
View file

@ -2,7 +2,7 @@
;;
;; Copyright (C) 2020-2024 Free Software Foundation, Inc.
;;
;; Maintainer: Ihor Radchenko <yantar92 at gmail dot com>
;; Maintainer: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: folding, visibility cycling, invisible text
;; URL: https://orgmode.org
;;
@ -35,9 +35,10 @@
(require 'org-macs)
(require 'org-fold)
(declare-function org-element-type "org-element" (element))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-lineage "org-element" (datum &optional types with-self))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element-lineage "org-element-ast" (datum &optional types with-self))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-display-inline-images "org" (&optional include-linked refresh beg end))
(declare-function org-get-tags "org" (&optional pos local fontify))
@ -115,6 +116,7 @@ than its value."
(const :tag "No limit" nil)
(integer :tag "Maximum level")))
(defvaralias 'org-hide-block-startup 'org-cycle-hide-block-startup)
(defcustom org-cycle-hide-block-startup nil
"Non-nil means entering Org mode will fold all blocks.
This can also be set in on a per-file basis with
@ -125,6 +127,7 @@ This can also be set in on a per-file basis with
:group 'org-cycle
:type 'boolean)
(defvaralias 'org-hide-drawer-startup 'org-cycle-hide-drawer-startup)
(defcustom org-cycle-hide-drawer-startup t
"Non-nil means entering Org mode will fold all drawers.
This can also be set in on a per-file basis with
@ -200,6 +203,7 @@ Special case: when 0, never leave empty lines in collapsed view."
:type 'integer)
(put 'org-cycle-separator-lines 'safe-local-variable 'integerp)
(defvaralias 'org-pre-cycle-hook 'org-cycle-pre-hook)
(defcustom org-cycle-pre-hook nil
"Hook that is run before visibility cycling is happening.
The function(s) in this hook must accept a single argument which indicates
@ -240,6 +244,7 @@ normal outline commands like `show-all', but not with the cycling commands."
:package-version '(Org . "9.6")
:type 'boolean)
(defvaralias 'org-tab-first-hook 'org-cycle-tab-first-hook)
(defvar org-cycle-tab-first-hook nil
"Hook for functions to attach themselves to TAB.
See `org-ctrl-c-ctrl-c-hook' for more information.
@ -335,6 +340,10 @@ same as `S-TAB') also when called without prefix argument."
(and org-cycle-level-after-item/entry-creation
(or (org-cycle-level)
(org-cycle-item-indentation))))
(when (and org-cycle-max-level
(or (not (integerp org-cycle-max-level))
(< org-cycle-max-level 1)))
(user-error "`org-cycle-max-level' must be a positive integer"))
(let* ((limit-level
(or org-cycle-max-level
(and (boundp 'org-inlinetask-min-level)
@ -388,8 +397,8 @@ same as `S-TAB') also when called without prefix argument."
((org-fold-hide-drawer-toggle nil t element))
;; Table: enter it or move to the next field.
((and (org-match-line "[ \t]*[|+]")
(org-element-lineage element '(table) t))
(if (and (eq 'table (org-element-type element))
(org-element-lineage element 'table t))
(if (and (org-element-type-p element 'table)
(eq 'table.el (org-element-property :type element)))
(message (substitute-command-keys "\\<org-mode-map>\
Use `\\[org-edit-special]' to edit table.el tables"))
@ -404,8 +413,8 @@ Use `\\[org-edit-special]' to edit table.el tables"))
t)))
(and item
(= (line-beginning-position)
(org-element-property :post-affiliated
item)))))
(org-element-post-affiliated
item)))))
(org-match-line org-outline-regexp))
(or (bolp) (not (eq org-cycle-emulate-tab 'exc-hl-bol))))
(org-cycle-internal-local))
@ -421,7 +430,7 @@ Use `\\[org-edit-special]' to edit table.el tables"))
(call-interactively (global-key-binding (kbd "TAB"))))
((or (eq org-cycle-emulate-tab t)
(and (memq org-cycle-emulate-tab '(white whitestart))
(save-excursion (beginning-of-line 1) (looking-at "[ \t]*"))
(save-excursion (forward-line 0) (looking-at "[ \t]*"))
(or (and (eq org-cycle-emulate-tab 'white)
(= (match-end 0) (line-end-position)))
(and (eq org-cycle-emulate-tab 'whitestart)
@ -480,7 +489,7 @@ Use `\\[org-edit-special]' to edit table.el tables"))
(save-excursion
(if (org-at-item-p)
(progn
(beginning-of-line)
(forward-line 0)
(setq struct (org-list-struct))
(setq eoh (line-end-position))
(setq eos (org-list-get-item-end-before-blank (point) struct))
@ -502,16 +511,16 @@ Use `\\[org-edit-special]' to edit table.el tables"))
(save-excursion
(org-list-search-forward (org-item-beginning-re) eos t))))))
;; Determine end invisible part of buffer (EOL)
(beginning-of-line 2)
(forward-line 1)
(if (eq org-fold-core-style 'text-properties)
(while (and (not (eobp)) ;this is like `next-line'
(org-fold-folded-p (1- (point))))
(goto-char (org-fold-next-visibility-change nil nil t))
(and (eolp) (beginning-of-line 2)))
(and (eolp) (forward-line 1)))
(while (and (not (eobp)) ;this is like `next-line'
(get-char-property (1- (point)) 'invisible))
(goto-char (next-single-char-property-change (point) 'invisible))
(and (eolp) (beginning-of-line 2))))
(and (eolp) (forward-line 1))))
(setq eol (point)))
;; Find out what to do next and set `this-command'
(cond
@ -545,7 +554,7 @@ Use `\\[org-edit-special]' to edit table.el tables"))
(save-excursion
(org-back-to-heading)
(while (org-list-search-forward (org-item-beginning-re) eos t)
(beginning-of-line 1)
(forward-line 0)
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(end (org-list-get-bottom-point struct)))
@ -608,7 +617,9 @@ With a numeric prefix, show all headlines up to that level."
(defun org-cycle-set-startup-visibility ()
"Set the visibility required by startup options and properties."
(cond
((eq org-startup-folded t)
;; `fold' is technically not allowed value, but it is often
;; intuitively tried by users by analogy with #+STARTUP: fold.
((memq org-startup-folded '(t fold overview))
(org-cycle-overview))
((eq org-startup-folded 'content)
(org-cycle-content))
@ -620,8 +631,10 @@ With a numeric prefix, show all headlines up to that level."
(org-cycle-content 4))
((eq org-startup-folded 'show5levels)
(org-cycle-content 5))
((or (eq org-startup-folded 'showeverything)
(eq org-startup-folded nil))
;; `nofold' and `showall' are technically not allowed values, but
;; they are often intuitively tried by users by analogy with
;; #+STARTUP: nofold or #STARUP: showall.
((memq org-startup-folded '(showeverything nil nofold showall))
(org-fold-show-all)))
(unless (eq org-startup-folded 'showeverything)
(when org-cycle-hide-block-startup (org-fold-hide-block-all))
@ -634,20 +647,21 @@ With a numeric prefix, show all headlines up to that level."
"Switch subtree visibility according to VISIBILITY property."
(interactive)
(let ((regexp (org-re-property "VISIBILITY")))
(org-with-point-at 1
(save-excursion
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(let ((state (match-string 3)))
(let ((state (match-string 3)))
(if (not (org-at-property-p)) (outline-next-heading)
(save-excursion
(org-back-to-heading t)
(org-fold-subtree t)
(pcase state
("folded"
("folded"
(org-fold-subtree t))
("children"
("children"
(org-fold-show-hidden-entry)
(org-fold-show-children))
("content"
("content"
;; Newline before heading will be outside the
;; narrowing. Make sure that it is revealed.
(org-fold-heading nil)
@ -655,10 +669,9 @@ With a numeric prefix, show all headlines up to that level."
(save-restriction
(org-narrow-to-subtree)
(org-cycle-content))))
((or "all" "showall")
((or "all" "showall")
(org-fold-show-subtree))
(_ nil)))
(org-end-of-subtree)))))))
(_ nil)))))))))
(defun org-cycle-overview ()
"Switch to overview mode, showing only top-level headlines."
@ -683,7 +696,7 @@ With a numeric prefix, show all headlines up to that level."
(defun org-cycle-content (&optional arg)
"Show all headlines in the buffer, like a table of contents.
With numerical argument N, show content up to level N."
With numerical argument ARG, show content up to level ARG."
(interactive "p")
(org-fold-show-all '(headings))
(save-excursion
@ -705,7 +718,9 @@ With numerical argument N, show content up to level N."
"Temporarily store scroll position to restore.")
(defun org-cycle-optimize-window-after-visibility-change (state)
"Adjust the window after a change in outline visibility.
This function is the default value of the hook `org-cycle-hook'."
This function is the default value of the hook `org-cycle-hook'.
STATE is the current outline visibility state. It should be one of
symbols `content', `all', `folded', `children', or `subtree'."
(when (get-buffer-window (current-buffer))
(let ((repeat (eq last-command this-command)))
(unless repeat
@ -791,7 +806,9 @@ STATE should be one of the symbols listed in the docstring of
(defun org-cycle-display-inline-images (state)
"Auto display inline images under subtree when cycling.
It works when `org-cycle-inline-images-display' is non-nil."
It works when `org-cycle-inline-images-display' is non-nil.
STATE is the current outline visibility state. It should be one of
symbols `content', `all', `folded', `children', or `subtree'."
(when org-cycle-inline-images-display
(pcase state
('children

65
lisp/org/org-datetree.el
View file

@ -99,16 +99,15 @@ If time-period is month, then group entries by month."
(month (calendar-extract-month d))
(day (calendar-extract-day d)))
(org-datetree--find-create
"^\\*+[ \t]+\\([12][0-9]\\{3\\}\\)\\(\\s-*?\
\\([ \t]:[[:alnum:]:_@#%%]+:\\)?\\s-*$\\)"
year)
"\\([12][0-9]\\{3\\}\\)"
year nil nil nil t)
(org-datetree--find-create
"^\\*+[ \t]+%d-\\([01][0-9]\\) \\w+$"
year month)
"%d-\\([01][0-9]\\) \\w+"
year month nil nil t)
(when (eq time-grouping 'day)
(org-datetree--find-create
"^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$"
year month day)))))
"%d-%02d-\\([0123][0-9]\\) \\w+"
year month day nil t)))))
;;;###autoload
(defun org-datetree-find-iso-week-create (d &optional keep-restriction)
@ -147,33 +146,51 @@ will be built under the headline at point."
(week (nth 0 iso-date)))
;; ISO 8601 week format is %G-W%V(-%u)
(org-datetree--find-create
"^\\*+[ \t]+\\([12][0-9]\\{3\\}\\)\\(\\s-*?\
\\([ \t]:[[:alnum:]:_@#%%]+:\\)?\\s-*$\\)"
weekyear nil nil
(format-time-string "%G" time))
"\\([12][0-9]\\{3\\}\\)"
weekyear nil nil (format-time-string "%G" time) t)
(org-datetree--find-create
"^\\*+[ \t]+%d-W\\([0-5][0-9]\\)$"
weekyear week nil
(format-time-string "%G-W%V" time))
"%d-W\\([0-5][0-9]\\)"
weekyear week nil (format-time-string "%G-W%V" time) t)
;; For the actual day we use the regular date instead of ISO week.
(org-datetree--find-create
"^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$"
year month day))))
"%d-%02d-\\([0123][0-9]\\) \\w+" year month day nil t))))
(defun org-datetree--find-create
(regex-template year &optional month day insert)
(regex-template year &optional month day insert match-title)
"Find the datetree matched by REGEX-TEMPLATE for YEAR, MONTH, or DAY.
REGEX-TEMPLATE is passed to `format' with YEAR, MONTH, and DAY as
arguments. Match group 1 is compared against the specified date
arguments.
If MATCH-TITLE is non-nil, REGEX-TEMPLATE is matched against
heading title and the exact regexp matched against heading line is:
(format org-complex-heading-regexp-format
(format regex-template year month day))
If MATCH-TITLE is nil, the regexp matched against heading line is
REGEX-TEMPLATE:
(format regex-template year month day)
Match group 1 in REGEX-TEMPLATE is compared against the specified date
component. If INSERT is non-nil and there is no match then it is
inserted into the buffer."
(when (or month day)
(org-narrow-to-subtree))
(let ((re (format regex-template year month day))
;; ensure that the first match group in REGEX-TEMPLATE
;; is the first inside `org-complex-heading-regexp-format'
(when (and match-title
(not (string-match-p "\\\\(\\?1:" regex-template))
(string-match "\\\\(" regex-template))
(setq regex-template (replace-match "\\(?1:" nil t regex-template)))
(let ((re (if match-title
(format org-complex-heading-regexp-format
(format regex-template year month day))
(format regex-template year month day)))
match)
(goto-char (point-min))
(while (and (setq match (re-search-forward re nil t))
(goto-char (match-beginning 1))
(goto-char (match-beginning 1))
(< (string-to-number (match-string 1)) (or day month year))))
(cond
((not match)
@ -181,9 +198,9 @@ inserted into the buffer."
(unless (bolp) (insert "\n"))
(org-datetree-insert-line year month day insert))
((= (string-to-number (match-string 1)) (or day month year))
(beginning-of-line))
(forward-line 0))
(t
(beginning-of-line)
(forward-line 0)
(org-datetree-insert-line year month day insert)))))
(defun org-datetree-insert-line (year &optional month day text)
@ -205,11 +222,11 @@ inserted into the buffer."
(save-excursion
(insert "\n")
(org-indent-line)
(org-insert-time-stamp
(org-insert-timestamp
(org-encode-time 0 0 0 day month year)
nil
(eq org-datetree-add-timestamp 'inactive))))
(beginning-of-line))
(forward-line 0))
(defun org-datetree-file-entry-under (txt d)
"Insert a node TXT into the date tree under date D."

207
lisp/org/org-duration.el
View file

@ -324,109 +324,110 @@ When optional argument CANONICAL is non-nil, ignore
`org-duration-units' and use standard time units value.
Raise an error if expected format is unknown."
(pcase (or fmt org-duration-format)
(`h:mm
(format "%d:%02d" (/ minutes 60) (mod minutes 60)))
(`h:mm:ss
(let* ((whole-minutes (floor minutes))
(seconds (mod (* 60 minutes) 60)))
(format "%s:%02d"
(org-duration-from-minutes whole-minutes 'h:mm)
seconds)))
((pred atom) (error "Invalid duration format specification: %S" fmt))
;; Mixed format. Call recursively the function on both parts.
((and duration-format
(let `(special . ,(and mode (or `h:mm:ss `h:mm)))
(assq 'special duration-format)))
(let* ((truncated-format
;; Remove "special" mode from duration format in order to
;; recurse properly. Also remove units smaller or equal
;; to an hour since H:MM part takes care of it.
(cl-remove-if-not
(lambda (pair)
(pcase pair
(`(,(and unit (pred stringp)) . ,_)
(> (org-duration--modifier unit canonical) 60))
(_ nil)))
duration-format))
(min-modifier ;smallest modifier above hour
(and truncated-format
(apply #'min
(mapcar (lambda (p)
(org-duration--modifier (car p) canonical))
truncated-format)))))
(if (or (null min-modifier) (< minutes min-modifier))
;; There is not unit above the hour or the smallest unit
;; above the hour is too large for the number of minutes we
;; need to represent. Use H:MM or H:MM:SS syntax.
(org-duration-from-minutes minutes mode canonical)
;; Represent minutes above hour using provided units and H:MM
;; or H:MM:SS below.
(let* ((units-part (* min-modifier (/ (floor minutes) min-modifier)))
(minutes-part (- minutes units-part))
(compact (memq 'compact duration-format)))
(concat
(org-duration-from-minutes units-part truncated-format canonical)
(and (not compact) " ")
(org-duration-from-minutes minutes-part mode))))))
;; Units format.
(duration-format
(let* ((fractional
(let ((digits (cdr (assq 'special duration-format))))
(and digits
(or (wholenump digits)
(error "Unknown formatting directive: %S" digits))
(format "%%.%df" digits))))
(selected-units
(sort (cl-remove-if
;; Ignore special format cells and compact option.
(lambda (pair)
(pcase pair
((or `compact `(special . ,_)) t)
(_ nil)))
duration-format)
(lambda (a b)
(> (org-duration--modifier (car a) canonical)
(org-duration--modifier (car b) canonical)))))
(separator (if (memq 'compact duration-format) "" " ")))
(cond
;; Fractional duration: use first unit that is either required
;; or smaller than MINUTES.
(fractional
(let* ((unit (car
(or (cl-find-if
(lambda (pair)
(pcase pair
(`(,u . ,req?)
(or req?
(<= (org-duration--modifier u canonical)
minutes)))))
selected-units)
;; Fall back to smallest unit.
(org-last selected-units))))
(modifier (org-duration--modifier unit canonical)))
(concat (format fractional (/ (float minutes) modifier)) unit)))
;; Otherwise build duration string according to available
;; units.
((org-string-nw-p
(org-trim
(mapconcat
(lambda (units)
(pcase-let* ((`(,unit . ,required?) units)
(modifier (org-duration--modifier unit canonical)))
(cond ((<= modifier minutes)
(let ((value (floor minutes modifier)))
(cl-decf minutes (* value modifier))
(format "%s%d%s" separator value unit)))
(required? (concat separator "0" unit))
(t ""))))
selected-units
""))))
;; No unit can properly represent MINUTES. Use the smallest
;; one anyway.
(t
(pcase-let ((`((,unit . ,_)) (last selected-units)))
(concat "0" unit))))))))
(if (< minutes 0) (concat "-" (org-duration-from-minutes (abs minutes) fmt canonical))
(pcase (or fmt org-duration-format)
(`h:mm
(format "%d:%02d" (/ minutes 60) (mod minutes 60)))
(`h:mm:ss
(let* ((whole-minutes (floor minutes))
(seconds (mod (* 60 minutes) 60)))
(format "%s:%02d"
(org-duration-from-minutes whole-minutes 'h:mm)
seconds)))
((pred atom) (error "Invalid duration format specification: %S" fmt))
;; Mixed format. Call recursively the function on both parts.
((and duration-format
(let `(special . ,(and mode (or `h:mm:ss `h:mm)))
(assq 'special duration-format)))
(let* ((truncated-format
;; Remove "special" mode from duration format in order to
;; recurse properly. Also remove units smaller or equal
;; to an hour since H:MM part takes care of it.
(cl-remove-if-not
(lambda (pair)
(pcase pair
(`(,(and unit (pred stringp)) . ,_)
(> (org-duration--modifier unit canonical) 60))
(_ nil)))
duration-format))
(min-modifier ;smallest modifier above hour
(and truncated-format
(apply #'min
(mapcar (lambda (p)
(org-duration--modifier (car p) canonical))
truncated-format)))))
(if (or (null min-modifier) (< minutes min-modifier))
;; There is not unit above the hour or the smallest unit
;; above the hour is too large for the number of minutes we
;; need to represent. Use H:MM or H:MM:SS syntax.
(org-duration-from-minutes minutes mode canonical)
;; Represent minutes above hour using provided units and H:MM
;; or H:MM:SS below.
(let* ((units-part (* min-modifier (/ (floor minutes) min-modifier)))
(minutes-part (- minutes units-part))
(compact (memq 'compact duration-format)))
(concat
(org-duration-from-minutes units-part truncated-format canonical)
(and (not compact) " ")
(org-duration-from-minutes minutes-part mode))))))
;; Units format.
(duration-format
(let* ((fractional
(let ((digits (cdr (assq 'special duration-format))))
(and digits
(or (wholenump digits)
(error "Unknown formatting directive: %S" digits))
(format "%%.%df" digits))))
(selected-units
(sort (cl-remove-if
;; Ignore special format cells and compact option.
(lambda (pair)
(pcase pair
((or `compact `(special . ,_)) t)
(_ nil)))
duration-format)
(lambda (a b)
(> (org-duration--modifier (car a) canonical)
(org-duration--modifier (car b) canonical)))))
(separator (if (memq 'compact duration-format) "" " ")))
(cond
;; Fractional duration: use first unit that is either required
;; or smaller than MINUTES.
(fractional
(let* ((unit (car
(or (cl-find-if
(lambda (pair)
(pcase pair
(`(,u . ,req?)
(or req?
(<= (org-duration--modifier u canonical)
minutes)))))
selected-units)
;; Fall back to smallest unit.
(org-last selected-units))))
(modifier (org-duration--modifier unit canonical)))
(concat (format fractional (/ (float minutes) modifier)) unit)))
;; Otherwise build duration string according to available
;; units.
((org-string-nw-p
(org-trim
(mapconcat
(lambda (units)
(pcase-let* ((`(,unit . ,required?) units)
(modifier (org-duration--modifier unit canonical)))
(cond ((<= modifier minutes)
(let ((value (floor minutes modifier)))
(cl-decf minutes (* value modifier))
(format "%s%d%s" separator value unit)))
(required? (concat separator "0" unit))
(t ""))))
selected-units
""))))
;; No unit can properly represent MINUTES. Use the smallest
;; one anyway.
(t
(pcase-let ((`((,unit . ,_)) (last selected-units)))
(concat "0" unit)))))))))
;;;###autoload
(defun org-duration-h:mm-only-p (times)

1150
lisp/org/org-element-ast.el Normal file
View file

File diff suppressed because it is too large Load diff

6326
lisp/org/org-element.el
View file

File diff suppressed because it is too large Load diff

8
lisp/org/org-entities.el
View file

@ -29,6 +29,7 @@
(require 'org-macs)
(org-assert-version)
(require 'seq) ; Emacs 27 does not preload seq.el; for `seq-every-p'.
(declare-function org-mode "org" ())
(declare-function org-toggle-pretty-entities "org" ())
@ -277,8 +278,10 @@ packages to be loaded, add these packages to `org-latex-packages-alist'."
("vert" "\\vert{}" t "&vert;" "|" "|" "|")
("vbar" "|" nil "|" "|" "|" "|")
("brvbar" "\\textbrokenbar{}" nil "&brvbar;" "|" "¦" "¦")
("S" "\\S" nil "&sect;" "paragraph" "§" "§")
("sect" "\\S" nil "&sect;" "paragraph" "§" "§")
("S" "\\S" nil "&sect;" "section" "§" "§")
("sect" "\\S" nil "&sect;" "section" "§" "§")
("P" "\\P{}" nil "&para;" "paragraph" "" "")
("para" "\\P{}" nil "&para;" "paragraph" "" "")
("amp" "\\&" nil "&amp;" "&" "&" "&")
("lt" "\\textless{}" nil "&lt;" "<" "<" "<")
("gt" "\\textgreater{}" nil "&gt;" ">" ">" ">")
@ -494,7 +497,6 @@ packages to be loaded, add these packages to `org-latex-packages-alist'."
("checkmark" "\\checkmark" t "&check;" "[checkmark]" "[checkmark]" "✓")
"** Miscellaneous (seldom used)"
("para" "\\P{}" nil "&para;" "[pilcrow]" "" "")
("ordf" "\\textordfeminine{}" nil "&ordf;" "_a_" "ª" "ª")
("ordm" "\\textordmasculine{}" nil "&ordm;" "_o_" "º" "º")
("cedil" "\\c{}" nil "&cedil;" "[cedilla]" "¸" "¸")

8
lisp/org/org-faces.el
View file

@ -389,6 +389,10 @@ changes."
"Face used for tables."
:group 'org-faces)
(defface org-table-row '((t :inherit org-table))
"Face used to fontify whole table rows (including newlines and indentation)."
:group 'org-faces)
(defface org-table-header '((t :inherit org-table
:background "LightGray"
:foreground "Black"))
@ -660,6 +664,10 @@ month and 365.24 days for a year)."
"Face used for agenda entries that come from the Emacs diary."
:group 'org-faces)
(defface org-agenda-calendar-daterange '((t :inherit default))
"Face used to show entries with a date range in the agenda."
:group 'org-faces)
(defface org-agenda-calendar-event '((t :inherit default))
"Face used to show events and appointments in the agenda."
:group 'org-faces)

12
lisp/org/org-feed.el
View file

@ -475,7 +475,7 @@ This will find DRAWER and extract the alist."
(goto-char pos)
(let ((end (save-excursion (org-end-of-subtree t t))))
(if (re-search-forward
(concat "^[ \t]*:" drawer ":[ \t]*\n\\([^\000]*?\\)\n[ \t]*:END:")
(concat "^[ \t]*:" drawer ":[ \t]*\n\\(\\(?:.\\|\n\\)*?\\)\n[ \t]*:END:")
end t)
(read (match-string 1))
nil))))
@ -495,7 +495,7 @@ This will find DRAWER and extract the alist."
(match-beginning 0)))))
(outline-next-heading)
(insert " :" drawer ":\n :END:\n")
(beginning-of-line 0))
(forward-line -1))
(insert (pp-to-string status)))))
(defun org-feed-add-items (pos entries)
@ -508,7 +508,7 @@ This will find DRAWER and extract the alist."
(setq level (org-get-valid-level (length (match-string 1)) 1))
(org-end-of-subtree t t)
(skip-chars-backward " \t\n")
(beginning-of-line 2)
(forward-line 1)
(setq pos (point))
(while (setq entry (pop entries))
(org-paste-subtree level entry 'yank))
@ -565,7 +565,7 @@ If that property is already present, nothing changes."
(let ((v (plist-get entry (intern (concat ":" name)))))
(save-excursion
(save-match-data
(beginning-of-line)
(forward-line 0)
(if (looking-at
(concat "^\\([ \t]*\\)%" name "[ \t]*$"))
(org-feed-make-indented-block
@ -633,7 +633,7 @@ containing the properties `:guid' and `:item-full-text'."
end (and (re-search-forward "</item>" nil t)
(match-beginning 0)))
(setq item (buffer-substring beg end)
guid (if (string-match "<guid\\>.*?>\\([^\000]*?\\)</guid>" item)
guid (if (string-match "<guid\\>.*?>\\(\\(?:.\\|\n\\)*?\\)</guid>" item)
(xml-substitute-special (match-string-no-properties 1 item))))
(setq entry (list :guid guid :item-full-text item))
(push entry entries)
@ -647,7 +647,7 @@ containing the properties `:guid' and `:item-full-text'."
(with-temp-buffer
(insert (plist-get entry :item-full-text))
(goto-char (point-min))
(while (re-search-forward "<\\([a-zA-Z]+\\>\\).*?>\\([^\000]*?\\)</\\1>"
(while (re-search-forward "<\\([a-zA-Z]+\\>\\).*?>\\(\\(?:.\\|\n\\)*?\\)</\\1>"
nil t)
(setq entry (plist-put entry
(intern (concat ":" (match-string 1)))

347
lisp/org/org-fold-core.el
View file

@ -2,7 +2,7 @@
;;
;; Copyright (C) 2020-2024 Free Software Foundation, Inc.
;;
;; Author: Ihor Radchenko <yantar92 at gmail dot com>
;; Author: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: folding, invisible text
;; URL: https://orgmode.org
;;
@ -280,16 +280,17 @@
;;; Customization
(defcustom org-fold-core-style 'text-properties
(defcustom org-fold-core-style (if (version< emacs-version "29")
'text-properties
'overlays)
"Internal implementation detail used to hide folded text.
Can be either `text-properties' or `overlays'.
The former is faster on large files, while the latter is generally
less error-prone with regard to third-party packages that haven't yet
adapted to the new folding implementation.
The former is faster on large files in Emacs <29, while the latter is
generally less error-prone with regard to third-party packages.
Important: This variable must be set before loading Org."
:group 'org
:package-version '(Org . "9.6")
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Overlays" overlays)
(const :tag "Text properties" text-properties)))
@ -380,6 +381,9 @@ The following properties are known:
`buffer-invisibility-spec' will be used as is.
Note that changing this property from nil to t may
clear the setting in `buffer-invisibility-spec'.
- :font-lock :: non-nil means that newlines after the fold should
be re-fontified upon folding/unfolding. See
`org-activate-folds'.
- :alias :: a list of aliases for the SPEC-SYMBOL.
- :fragile :: Must be a function accepting two arguments.
Non-nil means that changes in region may cause
@ -424,7 +428,7 @@ Return nil when there is no matching folding spec."
(unless org-fold-core--spec-symbols
(dolist (spec (org-fold-core-folding-spec-list))
(push (cons spec spec) org-fold-core--spec-symbols)
(dolist (alias (assq :alias (assq spec org-fold-core--specs)))
(dolist (alias (cdr (assq :alias (assq spec org-fold-core--specs))))
(push (cons alias spec) org-fold-core--spec-symbols))))
(alist-get spec-or-alias org-fold-core--spec-symbols)))
@ -553,7 +557,10 @@ and the setup appears to be created for different buffer,
copy the old invisibility state into new buffer-local text properties,
unless RETURN-ONLY is non-nil."
(if (eq org-fold-core-style 'overlays)
(org-fold-core-get-folding-property-symbol spec nil 'global)
(or (gethash (cons 'global spec) org-fold-core--property-symbol-cache)
(puthash (cons 'global spec)
(org-fold-core-get-folding-property-symbol spec nil 'global)
org-fold-core--property-symbol-cache))
(let* ((buf (or buffer (current-buffer))))
;; Create unique property symbol for SPEC in BUFFER
(let ((local-prop (or (gethash (cons buf spec) org-fold-core--property-symbol-cache)
@ -574,15 +581,6 @@ unless RETURN-ONLY is non-nil."
;; would contain folding properties, which are not
;; matching the generated `local-prop'.
(unless (member local-prop (cdr (assq 'invisible char-property-alias-alist)))
;; Add current buffer to the list of indirect buffers in the base buffer.
(when (buffer-base-buffer)
(with-current-buffer (buffer-base-buffer)
(setq-local org-fold-core--indirect-buffers
(let (bufs)
(org-fold-core-cycle-over-indirect-buffers
(push (current-buffer) bufs))
(push buf bufs)
(delete-dups bufs)))))
;; Copy all the old folding properties to preserve the folding state
(with-silent-modifications
(dolist (old-prop (cdr (assq 'invisible char-property-alias-alist)))
@ -633,14 +631,27 @@ unless RETURN-ONLY is non-nil."
text-property-default-nonsticky
full-prop-list))))))))))))))
(defun org-fold-core--update-buffer-folds ()
"Copy folding state in a new buffer with text copied from old buffer."
(org-fold-core--property-symbol-get-create (car (org-fold-core-folding-spec-list))))
(defun org-fold-core-decouple-indirect-buffer-folds ()
"Copy and decouple folding state in a newly created indirect buffer.
This function is mostly intended to be used in
`clone-indirect-buffer-hook'."
;; Add current buffer to the list of indirect buffers in the base buffer.
(when (buffer-base-buffer)
(with-current-buffer (buffer-base-buffer)
(setq-local org-fold-core--indirect-buffers
(let (bufs)
(org-fold-core-cycle-over-indirect-buffers
(push (current-buffer) bufs))
(push (current-buffer) bufs)
(delete-dups bufs)))))
(when (and (buffer-base-buffer)
(eq org-fold-core-style 'text-properties)
(not (memql 'ignore-indirect org-fold-core--optimise-for-huge-buffers)))
(org-fold-core--property-symbol-get-create (car (org-fold-core-folding-spec-list)))))
(org-fold-core--update-buffer-folds)))
;;; API
@ -694,7 +705,7 @@ The folding spec properties will be set to PROPERTIES (see
(let* ((full-properties (mapcar (lambda (prop) (cons prop (cdr (assq prop properties))))
'( :visible :ellipsis :isearch-ignore
:global :isearch-open :front-sticky
:rear-sticky :fragile :alias)))
:rear-sticky :fragile :alias :font-lock)))
(full-spec (cons spec full-properties)))
(add-to-list 'org-fold-core--specs full-spec append)
(mapc (lambda (prop-cons) (org-fold-core-set-folding-spec-property spec (car prop-cons) (cdr prop-cons) 'force)) full-properties)
@ -783,16 +794,19 @@ corresponding folding spec (if the text is folded using that spec)."
(when (and spec (not (eq spec 'all))) (org-fold-core--check-spec spec))
(org-with-point-at pom
(cond
((eq spec 'all)
(let ((result))
(dolist (spec (org-fold-core-folding-spec-list))
(let ((val (get-char-property (point) (org-fold-core--property-symbol-get-create spec nil t))))
(when val (push val result))))
(reverse result)))
((null spec)
(let ((result (get-char-property (point) 'invisible)))
(when (org-fold-core-folding-spec-p result) result)))
(t (get-char-property (point) (org-fold-core--property-symbol-get-create spec nil t)))))))
((or (null spec) (eq spec 'all))
(catch :single-spec
(let ((result))
(dolist (lspec (org-fold-core-folding-spec-list))
(let ((val (if (eq org-fold-core-style 'text-properties)
(get-text-property (point) (org-fold-core--property-symbol-get-create lspec nil t))
(get-char-property (point) (org-fold-core--property-symbol-get-create lspec nil t)))))
(when (and val (null spec)) (throw :single-spec val))
(when val (push val result))))
(reverse result))))
(t (if (eq org-fold-core-style 'text-properties)
(get-text-property (point) (org-fold-core--property-symbol-get-create spec nil t))
(get-char-property (point) (org-fold-core--property-symbol-get-create spec nil t))))))))
(defun org-fold-core-get-folding-specs-in-region (beg end)
"Get all folding specs in region from BEG to END."
@ -843,13 +857,20 @@ If PREVIOUS-P is non-nil, search backwards."
(next-change (if previous-p
(if ignore-hidden-p
(lambda (p) (org-fold-core-previous-folding-state-change (org-fold-core-get-folding-spec nil p) p limit))
(lambda (p) (max limit (1- (previous-single-char-property-change p 'invisible nil limit)))))
(lambda (p) (max limit (previous-single-char-property-change p 'invisible nil limit))))
(if ignore-hidden-p
(lambda (p) (org-fold-core-next-folding-state-change (org-fold-core-get-folding-spec nil p) p limit))
(lambda (p) (next-single-char-property-change p 'invisible nil limit)))))
(next pos))
(while (and (funcall cmp next limit)
(not (org-xor invisible-initially? (funcall invisible-p next))))
(not (org-xor
invisible-initially?
(funcall invisible-p
(if previous-p
;; NEXT-1 -> NEXT is the change.
(max limit (1- next))
;; NEXT -> NEXT+1 is the change.
next)))))
(setq next (funcall next-change next)))
next))
@ -897,14 +918,19 @@ Search backwards when PREVIOUS-P is non-nil."
(unless spec-or-alias
(setq spec-or-alias (org-fold-core-folding-spec-list)))
(setq pos (or pos (point)))
(apply (if previous-p
#'max
#'min)
(mapcar (if previous-p
(lambda (prop) (max (or limit (point-min)) (previous-single-char-property-change pos prop nil (or limit (point-min)))))
(lambda (prop) (next-single-char-property-change pos prop nil (or limit (point-max)))))
(mapcar (lambda (el) (org-fold-core--property-symbol-get-create el nil t))
spec-or-alias))))
(let ((limit (or limit (if previous-p (point-min) (point-max)))))
(catch :limit
(dolist (prop (mapcar
(lambda (el)
(org-fold-core--property-symbol-get-create el nil t))
spec-or-alias))
(when (= limit pos) (throw :limit limit))
(setq
limit
(if previous-p
(previous-single-char-property-change pos prop nil limit)
(next-single-char-property-change pos prop nil limit))))
limit)))
(defun org-fold-core-previous-folding-state-change (&optional spec-or-alias pos limit)
"Call `org-fold-core-next-folding-state-change' searching backwards."
@ -985,6 +1011,24 @@ WITH-MARKERS must be nil when RELATIVE is non-nil."
;;;;; Region visibility
(defvar org-fold-core--keep-overlays nil
"When non-nil, `org-fold-core-region' will not remove existing overlays.")
(defvar org-fold-core--isearch-overlays) ; defined below
(defmacro org-fold-core--keep-overlays (&rest body)
"Run BODY with `org-fold-core--keep-overlays' set to t."
(declare (debug (body)))
`(let ((org-fold-core--keep-overlays t))
,@body))
(defvar org-fold-core--isearch-active nil
"When non-nil, `org-fold-core-region' records created overlays.
New overlays will be added to `org-fold-core--isearch-overlays'.")
(defmacro org-fold-core--with-isearch-active (&rest body)
"Run BODY with `org-fold-core--isearch-active' set to t."
(declare (debug (body)))
`(let ((org-fold-core--isearch-active t))
,@body))
;; This is the core function performing actual folding/unfolding. The
;; folding state is stored in text property (folding property)
;; returned by `org-fold-core--property-symbol-get-create'. The value of the
@ -997,7 +1041,43 @@ If SPEC-OR-ALIAS is omitted and FLAG is nil, unfold everything in the region."
(when spec (org-fold-core--check-spec spec))
(with-silent-modifications
(org-with-wide-buffer
(when (eq org-fold-core-style 'overlays) (remove-overlays from to 'invisible spec))
;; Arrange fontifying newlines after all the folds between FROM
;; and TO to match the first character before the fold; not the
;; last as per Emacs defaults. This makes :extend faces span
;; past the ellipsis. See bug#65896. The face properties are
;; assigned via `org-activate-folds'.
(when (or (not spec) (org-fold-core-get-folding-spec-property spec :font-lock))
(when (equal ?\n (char-after from))
(font-lock-flush from (1+ from)))
(when (equal ?\n (char-after to))
(font-lock-flush to (1+ to)))
(dolist (region (org-fold-core-get-regions :from from :to to :specs spec))
(when (equal ?\n (char-after (cadr region)))
(font-lock-flush (cadr region) (1+ (cadr region))))
;; Re-fontify beginning of the fold - we may
;; unfold inside an existing fold, with FROM begin a newline
;; after spliced fold.
(when (equal ?\n (char-after (car region)))
(font-lock-flush (car region) (1+ (car region))))))
(when (eq org-fold-core-style 'overlays)
(if org-fold-core--keep-overlays
(mapc
(lambda (ov)
(when (or (not spec)
(eq spec (overlay-get ov 'invisible)))
(when (and org-fold-core--isearch-active
(overlay-get ov 'invisible)
(org-fold-core-get-folding-spec-property
(overlay-get ov 'invisible) :isearch-open))
(when (overlay-get ov 'invisible)
(overlay-put ov 'org-invisible (overlay-get ov 'invisible)))
(overlay-put ov 'invisible nil)
(when org-fold-core--isearch-active
(cl-pushnew ov org-fold-core--isearch-overlays)))))
(overlays-in from to))
(when spec
(remove-overlays from to 'org-invisible spec)
(remove-overlays from to 'invisible spec))))
(if flag
(if (not spec)
(error "Calling `org-fold-core-region' with missing SPEC")
@ -1007,17 +1087,14 @@ If SPEC-OR-ALIAS is omitted and FLAG is nil, unfold everything in the region."
(let ((o (make-overlay from to nil
(org-fold-core-get-folding-spec-property spec :front-sticky)
(org-fold-core-get-folding-spec-property spec :rear-sticky))))
(when org-fold-core--isearch-active
(push o org-fold-core--isearch-overlays))
(overlay-put o 'evaporate t)
(overlay-put o (org-fold-core--property-symbol-get-create spec) spec)
(overlay-put o 'invisible spec)
(overlay-put o 'isearch-open-invisible #'org-fold-core--isearch-show)
;; FIXME: Disabling to work around Emacs bug#60399
;; and https://orgmode.org/list/87zgb6tk6h.fsf@localhost.
;; The proper fix will require making sure that
;; `org-fold-core-isearch-open-function' does not
;; delete the overlays used by isearch.
;; (overlay-put o 'isearch-open-invisible-temporary #'org-fold-core--isearch-show-temporary)
)
;; Preserve priority.
(overlay-put o 'priority (length (member spec (org-fold-core-folding-spec-list))))
(overlay-put o 'isearch-open-invisible #'org-fold-core--isearch-show))
(put-text-property from to (org-fold-core--property-symbol-get-create spec) spec)
(put-text-property from to 'isearch-open-invisible #'org-fold-core--isearch-show)
(put-text-property from to 'isearch-open-invisible-temporary #'org-fold-core--isearch-show-temporary)
@ -1041,7 +1118,13 @@ If SPEC-OR-ALIAS is omitted and FLAG is nil, unfold everything in the region."
(setq pos next))
(setq pos (next-single-char-property-change pos 'invisible nil to)))))))
(when (eq org-fold-core-style 'text-properties)
(remove-text-properties from to (list (org-fold-core--property-symbol-get-create spec) nil)))))))))
(remove-text-properties from to (list (org-fold-core--property-symbol-get-create spec) nil)))))
;; Re-calculate trailing faces for all the folds revealed
;; by unfolding or created by folding.
(when (or (not spec) (org-fold-core-get-folding-spec-property spec :font-lock))
(dolist (region (org-fold-core-get-regions :from from :to to :specs spec))
(when (equal ?\n (char-after (cadr region)))
(font-lock-flush (cadr region) (1+ (cadr region))))))))))
(cl-defmacro org-fold-core-regions (regions &key override clean-markers relative)
"Fold every region in REGIONS list in current buffer.
@ -1104,13 +1187,19 @@ TYPE can be either `text-properties' or `overlays'."
(setq-local isearch-filter-predicate #'org-fold-core--isearch-filter-predicate-text-properties))
(`overlays
(when (eq org-fold-core-style 'text-properties)
(setq-local isearch-filter-predicate #'org-fold-core--isearch-filter-predicate-overlays)
(add-hook 'isearch-mode-end-hook #'org-fold-core--clear-isearch-overlays nil 'local)))
(add-function :before (local 'isearch-filter-predicate) #'org-fold-core--create-isearch-overlays)
;; When `isearch-filter-predicate' is called outside isearch,
;; it is common that `isearch-mode-end-hook' does not get
;; executed, but `isearch-clean-overlays' usually does.
(advice-add
'isearch-clean-overlays :after
#'org-fold-core--clear-isearch-overlays
'((name . isearch-clean-overlays@org-fold-core)))))
(_ (error "%s: Unknown type of setup for `org-fold-core--isearch-setup'" type))))
(defun org-fold-core--isearch-reveal (pos)
"Default function used to reveal hidden text at POS for isearch."
(let ((region (org-fold-core-get-region-at-point pos)))
(let ((region (org-fold-core-get-region-at-point nil pos)))
(org-fold-core-region (car region) (cdr region) nil)))
(defun org-fold-core--isearch-filter-predicate-text-properties (beg end)
@ -1145,34 +1234,37 @@ This function is intended to be used as `isearch-filter-predicate'."
"Clear `org-fold-core--isearch-local-regions'."
(clrhash org-fold-core--isearch-local-regions))
(defun org-fold-core--isearch-show (_)
"Reveal text at point found by isearch."
(funcall org-fold-core-isearch-open-function (point)))
(defun org-fold-core--isearch-show (overlay-or-region)
"Reveal text at OVERLAY-OR-REGION found by isearch."
(let (beg end)
(if (overlayp overlay-or-region)
(setq beg (overlay-start overlay-or-region)
end (overlay-end overlay-or-region))
(setq beg (car overlay-or-region)
end (cdr overlay-or-region)))
;; FIXME: Reveal the match (usually point, but may sometimes go beyond the region).
(when (< beg (point) end)
(funcall org-fold-core-isearch-open-function (point)))
(if (overlayp overlay-or-region)
(delete-overlay overlay-or-region)
(org-fold-core-region beg end nil))))
(defun org-fold-core--isearch-show-temporary (region hide-p)
"Temporarily reveal text in REGION.
Hide text instead if HIDE-P is non-nil.
REGION can also be an overlay in current buffer."
(when (overlayp region)
(setq region (cons (overlay-start region)
(overlay-end region))))
(if (not hide-p)
(let ((pos (car region)))
(while (< pos (cdr region))
(let ((spec-no-open
(catch :found
(dolist (spec (org-fold-core-get-folding-spec 'all pos))
(unless (org-fold-core-get-folding-spec-property spec :isearch-open)
(throw :found spec))))))
(if spec-no-open
;; Skip regions folded with folding specs that cannot be opened.
(setq pos (org-fold-core-next-folding-state-change spec-no-open pos (cdr region)))
(dolist (spec (org-fold-core-get-folding-spec 'all pos))
(push (cons spec (org-fold-core-get-region-at-point spec pos)) (gethash region org-fold-core--isearch-local-regions)))
(org-fold-core--isearch-show region)
(setq pos (org-fold-core-next-folding-state-change nil pos (cdr region)))))))
(mapc (lambda (val) (org-fold-core-region (cadr val) (cddr val) t (car val))) (gethash region org-fold-core--isearch-local-regions))
(remhash region org-fold-core--isearch-local-regions)))
(save-match-data ; match data must not be modified.
(let ((org-fold-core-style (if (overlayp region) 'overlays 'text-properties)))
(if hide-p
(if (not (overlayp region))
nil ;; FIXME: after isearch supports text properties.
(when (overlay-get region 'org-invisible)
(overlay-put region 'invisible (overlay-get region 'org-invisible))))
;; isearch expects all the temporarily opened overlays to exist.
;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=60399
(org-fold-core--keep-overlays
(org-fold-core--with-isearch-active
(org-fold-core--isearch-show region)))))))
(defvar-local org-fold-core--isearch-special-specs nil
"List of specs that can break visibility state when converted to overlays.
@ -1187,49 +1279,28 @@ instead of text properties. The created overlays will be stored in
(while (< pos end)
;; We need loop below to make sure that we clean all invisible
;; properties, which may be nested.
(dolist (spec (org-fold-core-get-folding-spec 'all pos))
(unless (org-fold-core-get-folding-spec-property spec :isearch-ignore)
(let* ((region (org-fold-core-get-region-at-point spec pos)))
(when (memq spec org-fold-core--isearch-special-specs)
(setq pos (min pos (car region)))
(setq end (max end (cdr region))))
;; Changing text properties is considered buffer modification.
;; We do not want it here.
(with-silent-modifications
(org-fold-core-region (car region) (cdr region) nil spec)
;; The overlay is modeled after `outline-flag-region'
;; [2020-05-09 Sat] overlay for 'outline blocks.
(let ((o (make-overlay (car region) (cdr region) nil 'front-advance)))
(overlay-put o 'evaporate t)
(overlay-put o 'invisible spec)
(overlay-put o 'org-invisible spec)
;; Make sure that overlays are applied in the same order
;; with the folding specs.
;; Note: `memq` returns cdr with car equal to the first
;; found matching element.
(overlay-put o 'priority (length (memq spec (org-fold-core-folding-spec-list))))
;; `delete-overlay' here means that spec information will be lost
;; for the region. The region will remain visible.
(if (org-fold-core-get-folding-spec-property spec :isearch-open)
(overlay-put o 'isearch-open-invisible #'delete-overlay)
(overlay-put o 'isearch-open-invisible #'ignore)
(overlay-put o 'isearch-open-invisible-temporary #'ignore))
(push o org-fold-core--isearch-overlays))))))
(setq pos (org-fold-core-next-folding-state-change nil pos end)))))
(defun org-fold-core--isearch-filter-predicate-overlays (beg end)
"Return non-nil if text between BEG and END is deemed visible by isearch.
This function is intended to be used as `isearch-filter-predicate'."
(org-fold-core--create-isearch-overlays beg end) ;; trick isearch by creating overlays in place of invisible text
(isearch-filter-visible beg end))
(catch :repeat
(dolist (spec (org-fold-core-get-folding-spec 'all pos))
(unless (org-fold-core-get-folding-spec-property spec :isearch-ignore)
(let* ((region (org-fold-core-get-region-at-point spec pos)))
(when (memq spec org-fold-core--isearch-special-specs)
(setq end (max end (cdr region)))
(when (< (car region) beg)
(setq beg (car region))
(setq pos beg)
(throw :repeat t)))
;; Changing text properties is considered buffer modification.
;; We do not want it here.
(with-silent-modifications
(org-fold-core-region (car region) (cdr region) nil spec)
(let ((org-fold-core-style 'overlays))
(org-fold-core--with-isearch-active
(org-fold-core-region (car region) (cdr region) t spec)))))))
(setq pos (org-fold-core-next-folding-state-change nil pos end))))))
(defun org-fold-core--clear-isearch-overlay (ov)
"Convert OV region back into using text properties."
(let ((spec (if isearch-mode-end-hook-quit
;; Restore all folds.
(overlay-get ov 'org-invisible)
;; Leave opened folds open.
(overlay-get ov 'invisible))))
(let ((spec (overlay-get ov 'invisible)))
;; Ignore deleted overlays.
(when (and spec
(overlay-buffer ov))
@ -1238,8 +1309,6 @@ This function is intended to be used as `isearch-filter-predicate'."
(with-silent-modifications
(when (<= (overlay-end ov) (point-max))
(org-fold-core-region (overlay-start ov) (overlay-end ov) t spec)))))
(when (member ov isearch-opened-overlays)
(setq isearch-opened-overlays (delete ov isearch-opened-overlays)))
(delete-overlay ov))
(defun org-fold-core--clear-isearch-overlays ()
@ -1254,6 +1323,8 @@ This function is intended to be used as `isearch-filter-predicate'."
"Non-nil: skip processing modifications in `org-fold-core--fix-folded-region'.")
(defvar org-fold-core--ignore-fragility-checks nil
"Non-nil: skip fragility checks in `org-fold-core--fix-folded-region'.")
(defvar org-fold-core--suppress-folding-fix nil
"Non-nil: skip folding fix in `org-fold-core--fix-folded-region'.")
(defmacro org-fold-core-ignore-modifications (&rest body)
"Run BODY ignoring buffer modifications in `org-fold-core--fix-folded-region'."
@ -1262,12 +1333,47 @@ This function is intended to be used as `isearch-filter-predicate'."
(unwind-protect (progn ,@body)
(setq org-fold-core--last-buffer-chars-modified-tick (buffer-chars-modified-tick)))))
(defmacro org-fold-core-suppress-folding-fix (&rest body)
"Run BODY skipping re-folding checks in `org-fold-core--fix-folded-region'."
(declare (debug (form body)) (indent 0))
`(let ((org-fold-core--suppress-folding-fix t))
(progn ,@body)))
(defmacro org-fold-core-ignore-fragility-checks (&rest body)
"Run BODY skipping :fragility checks in `org-fold-core--fix-folded-region'."
(declare (debug (form body)) (indent 0))
`(let ((org-fold-core--ignore-fragility-checks t))
(progn ,@body)))
(defvar org-fold-core--region-delayed-list nil
"List holding (MKFROM MKTO FLAG SPEC-OR-ALIAS) arguments to process.
The list is used by `org-fold-core--region-delayed'.")
(defun org-fold-core--region-delayed (from to flag &optional spec-or-alias)
"Call `org-fold-core-region' after current command.
Pass the same FROM, TO, FLAG, and SPEC-OR-ALIAS."
;; Setup delayed folding.
(add-hook 'post-command-hook #'org-fold-core--process-delayed)
(let ((frommk (make-marker))
(tomk (make-marker)))
(set-marker frommk from (current-buffer))
(set-marker tomk to (current-buffer))
(push (list frommk tomk flag spec-or-alias) org-fold-core--region-delayed-list)))
(defun org-fold-core--process-delayed ()
"Perform folding for `org-fold-core--region-delayed-list'."
(when org-fold-core--region-delayed-list
(mapc (lambda (args)
(when (and (buffer-live-p (marker-buffer (nth 0 args)))
(buffer-live-p (marker-buffer (nth 1 args)))
(< (nth 0 args) (nth 1 args)))
(org-with-point-at (car args)
(apply #'org-fold-core-region args))))
;; Restore the initial folding order.
(nreverse org-fold-core--region-delayed-list))
;; Cleanup `post-command-hook'.
(remove-hook 'post-command-hook #'org-fold-core--process-delayed)
(setq org-fold-core--region-delayed-list nil)))
(defvar-local org-fold-core--last-buffer-chars-modified-tick nil
"Variable storing the last return value of `buffer-chars-modified-tick'.")
@ -1295,7 +1401,7 @@ property, unfold the region if the :fragile function returns non-nil."
;; buffer. Work around Emacs bug#46982.
;; Re-hide text inserted in the middle/front/back of a folded
;; region.
(unless (equal from to) ; Ignore deletions.
(unless (or org-fold-core--suppress-folding-fix (equal from to)) ; Ignore deletions.
(when (eq org-fold-core-style 'text-properties)
(org-fold-core-cycle-over-indirect-buffers
(dolist (spec (org-fold-core-folding-spec-list))
@ -1385,7 +1491,10 @@ property, unfold the region if the :fragile function returns non-nil."
(cons fold-begin fold-end)
spec))
;; Reveal completely, not just from the SPEC.
(org-fold-core-region fold-begin fold-end nil)))))
;; Do it only after command is finished -
;; some Emacs commands assume that
;; visibility is not altered by `after-change-functions'.
(org-fold-core--region-delayed fold-begin fold-end nil)))))
;; Move to next fold.
(setq pos (org-fold-core-next-folding-state-change spec pos local-to)))))))))))))

170
lisp/org/org-fold.el
View file

@ -2,7 +2,7 @@
;;
;; Copyright (C) 2020-2024 Free Software Foundation, Inc.
;;
;; Author: Ihor Radchenko <yantar92 at gmail dot com>
;; Author: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: folding, invisible text
;; URL: https://orgmode.org
;;
@ -49,8 +49,6 @@
(require 'org-fold-core)
(defvar org-inlinetask-min-level)
(defvar org-link--link-folding-spec)
(defvar org-link--description-folding-spec)
(defvar org-odd-levels-only)
(defvar org-drawer-regexp)
(defvar org-property-end-re)
@ -61,11 +59,12 @@
(defvar org-element-headline-re)
(declare-function isearch-filter-visible "isearch" (beg end))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element--current-element "org-element" (limit &optional granularity mode structure))
(declare-function org-element--cache-active-p "org-element" ())
(declare-function org-toggle-custom-properties-visibility "org" ())
(declare-function org-item-re "org-list" ())
(declare-function org-up-heading-safe "org" ())
@ -189,7 +188,10 @@ smart Make point visible, and do insertion/deletion if it is
Never delete a previously invisible character or add in the
middle or right after an invisible region. Basically, this
allows insertion and backward-delete right before ellipses.
FIXME: maybe in this case we should not even show?"
FIXME: maybe in this case we should not even show?
This variable only affects commands listed in
`org-fold-catch-invisible-edits-commands'."
:group 'org-edit-structure
:version "24.1"
:type '(choice
@ -199,6 +201,33 @@ smart Make point visible, and do insertion/deletion if it is
(const :tag "Show invisible part and do the edit" show)
(const :tag "Be smart and do the right thing" smart)))
(defcustom org-fold-catch-invisible-edits-commands
;; We do not add non-Org commands here by default to avoid advising
;; globally. See `org-fold--advice-edit-commands'.
'((org-self-insert-command . insert)
(org-delete-backward-char . delete-backward)
(org-delete-char . delete)
(org-meta-return . insert)
(org-return . insert))
"Alist of commands where Org checks for invisible edits.
Each element is (COMMAND . KIND), where COMMAND is symbol representing
command as stored in `this-command' and KIND is symbol `insert',
symbol `delete', or symbol `delete-backward'.
The checks are performed around `point'.
This variable must be set before loading Org in order to take effect.
Also, see `org-fold-catch-invisible-edits'."
:group 'org-edit-structure
:package-version '("Org" . "9.7")
:type '(alist
:key-type symbol
:value-type (choice
(const insert)
(const delete)
(const delete-backward))))
;;; Core functionality
;;; API
@ -224,6 +253,7 @@ smart Make point visible, and do insertion/deletion if it is
(:ellipsis . ,ellipsis)
(:fragile . ,#'org-fold--reveal-outline-maybe)
(:isearch-open . t)
(:font-lock . t)
;; This is needed to make sure that inserting a
;; new planning line in folded heading is not
;; revealed. Also, the below combination of :front-sticky and
@ -236,6 +266,7 @@ smart Make point visible, and do insertion/deletion if it is
(:ellipsis . ,ellipsis)
(:fragile . ,#'org-fold--reveal-drawer-or-block-maybe)
(:isearch-open . t)
(:font-lock . t)
(:front-sticky . t)
(:alias . ( block center-block comment-block
dynamic-block example-block export-block
@ -245,10 +276,9 @@ smart Make point visible, and do insertion/deletion if it is
(:ellipsis . ,ellipsis)
(:fragile . ,#'org-fold--reveal-drawer-or-block-maybe)
(:isearch-open . t)
(:font-lock . t)
(:front-sticky . t)
(:alias . (drawer property-drawer)))
,org-link--description-folding-spec
,org-link--link-folding-spec)))
(:alias . (drawer property-drawer))))))
;;;; Searching and examining folded text
@ -358,7 +388,7 @@ of the current heading, or to 1 if the current line is not a heading."
(interactive (list
(cond
(current-prefix-arg (prefix-numeric-value current-prefix-arg))
((save-excursion (beginning-of-line)
((save-excursion (forward-line 0)
(looking-at outline-regexp))
(funcall outline-level))
(t 1))))
@ -419,20 +449,21 @@ Show the heading too, if it is currently invisible."
(defun org-fold-show-children (&optional level)
"Show all direct subheadings of this heading.
Prefix arg LEVEL is how many levels below the current level
should be shown. Default is enough to cause the following
heading to appear."
Prefix arg LEVEL is how many levels below the current level should be
shown. If direct subheadings are deeper than LEVEL, they are still
displayed."
(interactive "p")
(unless (org-before-first-heading-p)
(save-excursion
(org-with-limited-levels (org-back-to-heading t))
(let* ((current-level (funcall outline-level))
(parent-level current-level)
(max-level (org-get-valid-level
current-level
parent-level
(if level (prefix-numeric-value level) 1)))
(min-level-direct-child most-positive-fixnum)
(end (save-excursion (org-end-of-subtree t t)))
(regexp-fmt "^\\*\\{%d,%s\\}\\(?: \\|$\\)")
(past-first-child nil)
;; Make sure to skip inlinetasks.
(re (format regexp-fmt
current-level
@ -448,11 +479,12 @@ heading to appear."
;; MAX-LEVEL. Since we want to display it anyway, adjust
;; MAX-LEVEL accordingly.
(while (re-search-forward re end t)
(unless past-first-child
(setq re (format regexp-fmt
current-level
(max (funcall outline-level) max-level)))
(setq past-first-child t))
(setq current-level (funcall outline-level))
(when (< current-level min-level-direct-child)
(setq min-level-direct-child current-level
re (format regexp-fmt
parent-level
(max min-level-direct-child max-level))))
(org-fold-heading nil))))))
(defun org-fold-show-subtree ()
@ -496,12 +528,12 @@ Return a non-nil value when toggling is successful."
comment-block dynamic-block example-block export-block
quote-block special-block src-block verse-block))
(_ (error "Unknown category: %S" category))))
(let* ((post (org-element-property :post-affiliated element))
(let* ((post (org-element-post-affiliated element))
(start (save-excursion
(goto-char post)
(line-end-position)))
(end (save-excursion
(goto-char (org-element-property :end element))
(goto-char (org-element-end element))
(skip-chars-backward " \t\n")
(line-end-position))))
;; Do nothing when not before or at the block opening line or
@ -560,10 +592,12 @@ Return a non-nil value when toggling is successful."
(interactive)
(org-block-map (apply-partially #'org-fold-hide-block-toggle 'hide)))
(defun org-fold-hide-drawer-all ()
"Fold all drawers in the current buffer."
(let ((begin (point-min))
(end (point-max)))
(defun org-fold-hide-drawer-all (&optional begin end)
"Fold all drawers in the current buffer or active region BEGIN..END."
(interactive (list (and (use-region-p) (region-beginning))
(and (use-region-p) (region-end))))
(let ((begin (or begin (point-min)))
(end (or end (point-max))))
(org-fold--hide-drawers begin end)))
(defun org-fold--hide-drawers (begin end)
@ -582,7 +616,7 @@ Return a non-nil value when toggling is successful."
;; Make sure to skip drawer entirely or we might flag it
;; another time when matching its ending line with
;; `org-drawer-regexp'.
(goto-char (org-element-property :end drawer))))))))
(goto-char (org-element-end drawer))))))))
(defun org-fold-hide-archived-subtrees (beg end)
"Re-hide all archived subtrees after a visibility state change."
@ -591,7 +625,7 @@ Return a non-nil value when toggling is successful."
(re (concat org-outline-regexp-bol ".*:" org-archive-tag ":")))
(goto-char beg)
;; Include headline point is currently on.
(beginning-of-line)
(forward-line 0)
(while (and (< (point) end) (re-search-forward re end t))
(when (member org-archive-tag (org-get-tags nil t))
(org-fold-subtree t)
@ -626,33 +660,27 @@ DETAIL is either nil, `minimal', `local', `ancestors',
(when (org-invisible-p)
;; FIXME: No clue why, but otherwise the following might not work.
(redisplay)
(let ((region (org-fold-get-region-at-point)))
;; Reveal emphasis markers.
(when (eq detail 'local)
(let (org-hide-emphasis-markers
org-link-descriptive
org-pretty-entities
(org-hide-macro-markers nil)
(region (or (org-find-text-property-region (point) 'org-emphasis)
(org-find-text-property-region (point) 'org-macro)
(org-find-text-property-region (point) 'invisible)
region)))
;; Silence byte-compiler.
(ignore org-hide-macro-markers)
(when region
(org-with-point-at (car region)
(beginning-of-line)
(let (font-lock-extend-region-functions)
(font-lock-fontify-region (max (point-min) (1- (car region))) (cdr region))))))
;; Unfold links.
;; Reveal emphasis markers.
(when (eq detail 'local)
(let (org-hide-emphasis-markers
org-link-descriptive
org-pretty-entities
(org-hide-macro-markers nil)
(region (or (org-find-text-property-region (point) 'org-emphasis)
(org-find-text-property-region (point) 'org-macro)
(org-find-text-property-region (point) 'invisible))))
;; Silence byte-compiler.
(ignore org-hide-macro-markers)
(when region
(dolist (spec '(org-link org-link-description))
(org-fold-region (car region) (cdr region) nil spec))))
(when region
(dolist (spec (org-fold-core-folding-spec-list))
;; Links are taken care by above.
(unless (memq spec '(org-link org-link-description))
(org-fold-region (car region) (cdr region) nil spec))))))
(org-with-point-at (car region)
(forward-line 0)
(let (font-lock-extend-region-functions)
(font-lock-fontify-region (max (point-min) (1- (car region))) (cdr region)))))))
(let (region)
(dolist (spec (org-fold-core-folding-spec-list))
(setq region (org-fold-get-region-at-point spec))
(when region
(org-fold-region (car region) (cdr region) nil spec)))))
(unless (org-before-first-heading-p)
(org-with-limited-levels
(cl-case detail
@ -697,9 +725,10 @@ go to the parent and show the entire tree."
;;; Make isearch search in some text hidden via text properties.
(defun org-fold--isearch-reveal (&rest _)
(defun org-fold--isearch-reveal (pos)
"Reveal text at POS found by isearch."
(org-fold-show-context 'isearch))
(org-with-point-at pos
(org-fold-show-context 'isearch)))
;;; Handling changes in folded elements
@ -724,7 +753,7 @@ the contents consists of blank lines.
Assume that point is located at the header line."
(org-with-wide-buffer
(beginning-of-line)
(forward-line 0)
(org-fold-region
(max (point-min) (1- (point)))
(let ((endl (line-end-position)))
@ -735,7 +764,7 @@ Assume that point is located at the header line."
(if (equal (point)
(save-excursion
(goto-char endl)
(org-end-of-subtree)
(org-end-of-subtree t)
(skip-chars-forward "\n\t\r ")))
(point)
endl)))
@ -752,7 +781,7 @@ This function is intended to be used as :fragile property of
;; The line before beginning of the fold should be either a
;; headline or a list item.
(backward-char)
(beginning-of-line)
(forward-line 0)
;; Make sure that headline is not partially hidden.
(unless (org-fold-folded-p nil 'headline)
(org-fold--reveal-headline-at-point))
@ -764,14 +793,14 @@ This function is intended to be used as :fragile property of
(org-fold--reveal-headline-at-point))))
;; Make sure that headline after is not partially hidden.
(goto-char (cdr region))
(beginning-of-line)
(forward-line 0)
(unless (org-fold-folded-p nil 'headline)
(when (looking-at-p org-element-headline-re)
(org-fold--reveal-headline-at-point)))
;; Check the validity of headline
(goto-char (car region))
(backward-char)
(beginning-of-line)
(forward-line 0)
(unless (let ((case-fold-search t))
(looking-at (rx-to-string
`(or (regex ,(org-item-re))
@ -807,7 +836,7 @@ This function is intended to be used as :fragile property of
;; The line before beginning of the fold should be the
;; first line of the drawer/block.
(backward-char)
(beginning-of-line)
(forward-line 0)
(unless (let ((case-fold-search t))
(looking-at begin-re)) ; the match-data will be used later
(throw :exit (setq unfold? t))))
@ -827,7 +856,7 @@ This function is intended to be used as :fragile property of
;; The last line of the folded text should match `end-re'.
(save-excursion
(goto-char fold-end)
(beginning-of-line)
(forward-line 0)
(unless (let ((case-fold-search t))
(looking-at end-re))
(throw :exit (setq unfold? t))))
@ -901,6 +930,19 @@ The detailed reaction depends on the user option
;; Don't do the edit, make the user repeat it in full visibility
(user-error "Edit in invisible region aborted, repeat to confirm with text visible"))))))))
(defun org-fold-check-before-invisible-edit-maybe (&rest _)
"Check before invisible command by `this-command'."
(when (derived-mode-p 'org-mode)
(pcase (alist-get this-command org-fold-catch-invisible-edits-commands)
((pred null) nil)
(kind (org-fold-check-before-invisible-edit kind)))))
(defun org-fold--advice-edit-commands ()
"Advice editing commands according to `org-fold-catch-invisible-edits-commands'.
The advices are installed in current buffer."
(dolist (command (mapcar #'car org-fold-catch-invisible-edits-commands))
(advice-add command :before #'org-fold-check-before-invisible-edit-maybe)))
(provide 'org-fold)
;;; org-fold.el ends here

73
lisp/org/org-footnote.el
View file

@ -45,9 +45,10 @@
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-class "org-element" (datum &optional parent))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-lineage "org-element" (blob &optional types with-self))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-lineage "org-element-ast" (blob &optional types with-self))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading))
(declare-function org-fill-paragraph "org" (&optional justify region))
(declare-function org-in-block-p "org" (names))
@ -136,15 +137,18 @@ Possible values are:
nil Prompt the user for each label.
t Create unique labels of the form [fn:1], [fn:2], etc.
anonymous Create anonymous footnotes
confirm Like t, but let the user edit the created value.
The label can be removed from the minibuffer to create
an anonymous footnote.
random Automatically generate a unique, random label."
:group 'org-footnote
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Prompt for label" nil)
(const :tag "Create automatic [fn:N]" t)
(const :tag "Offer automatic [fn:N] for editing" confirm)
(const :tag "Create anoymous [fn::]" anonymous)
(const :tag "Create a random label" random))
:safe #'symbolp)
@ -183,21 +187,21 @@ extracted will be filled again."
"Is point in a context where footnotes are allowed?"
(save-match-data
(not (or (org-at-comment-p)
(org-inside-LaTeX-fragment-p)
;; Avoid literal example.
(org-in-verbatim-emphasis)
(save-excursion
(beginning-of-line)
(looking-at "[ \t]*:[ \t]+"))
;; Avoid forbidden blocks.
(org-in-block-p org-footnote-forbidden-blocks)))))
(org-inside-LaTeX-fragment-p)
;; Avoid literal example.
(org-in-verbatim-emphasis)
(save-excursion
(forward-line 0)
(looking-at "[ \t]*:[ \t]+"))
;; Avoid forbidden blocks.
(org-in-block-p org-footnote-forbidden-blocks)))))
(defun org-footnote-at-reference-p ()
"Non-nil if point is at a footnote reference.
If so, return a list containing its label, beginning and ending
positions, and the definition, when inline."
(let ((reference (org-element-context)))
(when (eq 'footnote-reference (org-element-type reference))
(when (org-element-type-p reference 'footnote-reference)
(let ((end (save-excursion
(goto-char (org-element-property :end reference))
(skip-chars-backward " \t")
@ -223,7 +227,7 @@ defined locally.
The return value is nil if not at a footnote definition, and
a list with label, start, end and definition of the footnote
otherwise."
(pcase (org-element-lineage (org-element-at-point) '(footnote-definition) t)
(pcase (org-element-lineage (org-element-at-point) 'footnote-definition t)
(`nil nil)
(definition
(let* ((label (org-element-property :label definition))
@ -269,7 +273,7 @@ otherwise."
((memq type '(headline inlinetask))
(or (not (org-at-heading-p))
(and (save-excursion
(beginning-of-line)
(forward-line 0)
(and (let ((case-fold-search t))
(not (looking-at-p "\\*+ END[ \t]*$")))
(let ((case-fold-search nil))
@ -281,10 +285,10 @@ otherwise."
;; White spaces after an object or blank lines after an element
;; are OK.
((>= (point)
(save-excursion (goto-char (org-element-property :end context))
(skip-chars-backward " \r\t\n")
(if (eq (org-element-class context) 'object) (point)
(line-beginning-position 2)))))
(save-excursion (goto-char (org-element-property :end context))
(skip-chars-backward " \r\t\n")
(if (eq (org-element-class context) 'object) (point)
(line-beginning-position 2)))))
;; At the beginning of a footnote definition, right after the
;; label, is OK.
((eq type 'footnote-definition) (looking-at (rx space)))
@ -298,7 +302,7 @@ otherwise."
;; :contents-begin is not reliable on empty cells, so special
;; case it.
(<= (save-excursion (skip-chars-backward " \t") (point))
(org-element-property :contents-end context)))
(org-element-property :contents-end context)))
((let ((cbeg (org-element-property :contents-begin context))
(cend (org-element-property :contents-end context)))
(and cbeg (>= (point) cbeg) (<= (point) cend))))))))
@ -368,14 +372,14 @@ References are sorted according to a deep-reading order."
;; Ensure point is within the reference before parsing it.
(backward-char)
(let ((object (org-element-context)))
(when (eq (org-element-type object) 'footnote-reference)
(when (org-element-type-p object 'footnote-reference)
(let* ((label (org-element-property :label object))
(begin (org-element-property :begin object))
(size
(and (eq (org-element-property :type object) 'inline)
(- (org-element-property :contents-end object)
(org-element-property :contents-begin object)))))
(let ((d (org-element-lineage object '(footnote-definition))))
(let ((d (org-element-lineage object 'footnote-definition)))
(push (list label (copy-marker begin) (not d) size)
references)
(when d
@ -420,7 +424,7 @@ while collecting them."
(backward-char)
(let ((element (org-element-at-point)))
(let ((label (org-element-property :label element)))
(when (and (eq (org-element-type element) 'footnote-definition)
(when (and (org-element-type-p element 'footnote-definition)
(not (member label seen)))
(push label seen)
(let* ((beg (progn
@ -516,7 +520,7 @@ This function is meant to be used for fontification only."
;; Definition: also grab the last square bracket, matched in
;; `org-footnote-re' for non-inline footnotes.
((and (save-excursion
(beginning-of-line)
(forward-line 0)
(save-match-data (org-footnote-in-valid-context-p)))
(save-excursion
(end-of-line)
@ -633,8 +637,8 @@ This function ignores narrowing, if any."
(while (re-search-forward org-footnote-re nil t)
(backward-char)
(let ((context (org-element-context)))
(when (memq (org-element-type context)
'(footnote-definition footnote-reference))
(when (org-element-type-p
context '(footnote-definition footnote-reference))
(let ((label (org-element-property :label context)))
(when label (cl-pushnew label all :test #'equal))))))
all)))
@ -665,15 +669,16 @@ or new, let the user edit the definition of the footnote."
(user-error "Cannot insert a footnote here"))
(let* ((all (org-footnote-all-labels))
(label
(if (eq org-footnote-auto-label 'random)
(format "%x" (abs (random)))
(org-footnote-normalize-label
(let ((propose (org-footnote-unique-label all)))
(if (eq org-footnote-auto-label t) propose
(completing-read
"Label (leave empty for anonymous): "
(mapcar #'list all) nil nil
(and (eq org-footnote-auto-label 'confirm) propose))))))))
(unless (eq org-footnote-auto-label 'anonymous)
(if (eq org-footnote-auto-label 'random)
(format "%x" (abs (random)))
(org-footnote-normalize-label
(let ((propose (org-footnote-unique-label all)))
(if (eq org-footnote-auto-label t) propose
(completing-read
"Label (leave empty for anonymous): "
(mapcar #'list all) nil nil
(and (eq org-footnote-auto-label 'confirm) propose)))))))))
(cond ((not label)
(insert "[fn::]")
(backward-char 1))

24
lisp/org/org-goto.el
View file

@ -102,7 +102,11 @@ When nil, you can use these keybindings to navigate the buffer:
mouse-drag-region universal-argument org-occur)))
(dolist (cmd cmds)
(substitute-key-definition cmd cmd map global-map)))
(suppress-keymap map)
(if org-goto-auto-isearch
;; Suppress 0-9 interpreted as digital arguments.
;; Make them initiate isearch instead.
(suppress-keymap map t)
(suppress-keymap map))
(org-defkey map "\C-m" 'org-goto-ret)
(org-defkey map [(return)] 'org-goto-ret)
(org-defkey map [(left)] 'org-goto-left)
@ -145,7 +149,7 @@ When nil, you can use these keybindings to navigate the buffer:
(search-backward string bound noerror))
(when (save-match-data
(and (save-excursion
(beginning-of-line)
(forward-line 0)
(looking-at org-complex-heading-regexp))
(or (not (match-beginning 5))
(< (point) (match-beginning 5)))))
@ -172,7 +176,7 @@ When nil, you can use these keybindings to navigate the buffer:
(interactive)
(if (org-at-heading-p)
(progn
(beginning-of-line 1)
(forward-line 0)
(setq org-goto-selected-point (point)
org-goto-exit-command 'left)
(throw 'exit nil))
@ -211,12 +215,12 @@ position or nil."
(help (or help org-goto-help)))
(save-excursion
(save-window-excursion
(delete-other-windows)
(and (get-buffer "*org-goto*") (kill-buffer "*org-goto*"))
(pop-to-buffer-same-window
(condition-case nil
(pop-to-buffer
(condition-case nil
(make-indirect-buffer (current-buffer) "*org-goto*" t)
(error (make-indirect-buffer (current-buffer) "*org-goto*" t))))
(error (make-indirect-buffer (current-buffer) "*org-goto*" t)))
'(org-display-buffer-full-frame))
(let (temp-buffer-show-function temp-buffer-show-hook)
(with-output-to-temp-buffer "*Org Help*"
(princ (format help (if org-goto-auto-isearch
@ -234,8 +238,10 @@ position or nil."
(let (org-special-ctrl-a/e) (org-beginning-of-line))
(message "Select location and press RET")
(use-local-map org-goto-map)
(recursive-edit)))
(kill-buffer "*org-goto*")
(unwind-protect (recursive-edit)
(when-let ((window (get-buffer-window "*Org Help*" t)))
(quit-window 'kill window)))))
(when (get-buffer "*org-goto*") (kill-buffer "*org-goto*"))
(cons org-goto-selected-point org-goto-exit-command)))
;;;###autoload

11
lisp/org/org-habit.el
View file

@ -168,9 +168,10 @@ means of creating calendar-based reminders."
("m" . 30.4) ("y" . 365.25))))))
(error "Invalid duration string: %s" ts)))
(defun org-is-habit-p (&optional pom)
"Is the task at POM or point a habit?"
(string= "habit" (org-entry-get (or pom (point)) "STYLE")))
(defun org-is-habit-p (&optional epom)
"Is the task at EPOM or point a habit?
EPOM is an element, marker, or buffer position."
(string= "habit" (org-entry-get epom "STYLE" 'selective)))
(defun org-habit-parse-todo (&optional pom)
"Parse the TODO surrounding point for its habit-related data.
@ -263,8 +264,8 @@ This list represents a \"habit\" for the rest of this module."
(defsubst org-habit-repeat-type (habit)
(nth 5 habit))
(defsubst org-habit-get-priority (habit &optional moment)
"Determine the relative priority of a habit.
(defsubst org-habit-get-urgency (habit &optional moment)
"Determine the relative urgency of a habit.
This must take into account not just urgency, but consistency as well."
(let ((pri 1000)
(now (if moment (time-to-days moment) (org-today)))

297
lisp/org/org-id.el
View file

@ -29,13 +29,13 @@
;; are provided that create and retrieve such identifiers, and that find
;; entries based on the identifier.
;; Identifiers consist of a prefix (default "Org" given by the variable
;; Identifiers consist of a prefix (given by the variable
;; `org-id-prefix') and a unique part that can be created by a number
;; of different methods, see the variable `org-id-method'.
;; Org has a builtin method that uses a compact encoding of the creation
;; time of the ID, with microsecond accuracy. This virtually
;; guarantees globally unique identifiers, even if several people are
;; creating IDs at the same time in files that will eventually be used
;; of different methods, see the variable `org-id-method'. Org has a
;; builtin method that uses a compact encoding of the creation time of
;; the ID, with microsecond accuracy. This virtually guarantees
;; globally unique identifiers, even if several people are creating
;; IDs at the same time in files that will eventually be used
;; together.
;;
;; By default Org uses UUIDs as global unique identifiers.
@ -74,6 +74,7 @@
(org-assert-version)
(require 'org)
(require 'org-element-ast)
(require 'org-refile)
(require 'ol)
@ -128,6 +129,46 @@ nil Never use an ID to make a link, instead link using a text search for
(const :tag "Only use existing" use-existing)
(const :tag "Do not use ID to create link" nil)))
(defcustom org-id-link-consider-parent-id nil
"Non-nil means storing a link to an Org entry considers inherited IDs.
When this option is non-nil and `org-id-link-use-context' is
enabled, ID properties inherited from parent entries will be
considered when storing an ID link. If no ID is found in this
way, a new one may be created as normal (see
`org-id-link-to-org-use-id').
For example, given this org file:
* Parent
:PROPERTIES:
:ID: abc
:END:
** Child 1
** Child 2
With `org-id-link-consider-parent-id' and
`org-id-link-use-context' both enabled, storing a link with point
at \"Child 1\" will produce a link \"<id:abc::*Child 1>\". This
allows linking to uniquely-named sub-entries within a parent
entry with an ID, without requiring every sub-entry to have its
own ID."
:group 'org-link-store
:group 'org-id
:package-version '(Org . "9.7")
:type 'boolean)
(defcustom org-id-link-use-context t
"Non-nil means enables search string context in org-id links.
Search strings are added by `org-id-store-link' when both the
general option `org-link-context-for-files' and the org-id option
`org-id-link-use-context' are non-nil."
:group 'org-link-store
:group 'org-id
:package-version '(Org . "9.7")
:type 'boolean)
(defcustom org-id-uuid-program "uuidgen"
"The uuidgen program."
:group 'org-id
@ -225,6 +266,8 @@ systems."
(defvar org-id-locations nil
"List of files with IDs in those files.")
(defvar org-id--locations-checksum nil
"Last checksum corresponding to ID files and their modifications.")
(defvar org-id-files nil
"List of files that contain IDs.")
@ -277,25 +320,32 @@ This is useful when working with contents in a temporary buffer
that will be copied back to the original.")
;;;###autoload
(defun org-id-get (&optional pom create prefix)
"Get the ID property of the entry at point-or-marker POM.
If POM is nil, refer to the entry at point.
If the entry does not have an ID, the function returns nil.
However, when CREATE is non-nil, create an ID if none is present already.
PREFIX will be passed through to `org-id-new'.
In any case, the ID of the entry is returned."
(org-with-point-at pom
(let ((id (org-entry-get nil "ID")))
(cond
((and id (stringp id) (string-match "\\S-" id))
id)
(create
(setq id (org-id-new prefix))
(org-entry-put pom "ID" id)
(org-id-add-location id
(defun org-id-get (&optional epom create prefix inherit)
"Get the ID of the entry at EPOM.
EPOM is an element, marker, or buffer position. If EPOM is nil,
refer to the entry at point.
If INHERIT is non-nil, ID properties inherited from parent
entries are considered. Otherwise, only ID properties on the
entry itself are considered.
When CREATE is nil, return the ID of the entry if found,
otherwise nil. When CREATE is non-nil, create an ID if none has
been found, and return the new ID. PREFIX will be passed through
to `org-id-new'."
(let ((id (org-entry-get epom "ID" (and inherit t))))
(cond
((and id (stringp id) (string-match "\\S-" id))
id)
(create
(setq id (org-id-new prefix))
(org-entry-put epom "ID" id)
(org-with-point-at epom
(org-id-add-location id
(or org-id-overriding-file-name
(buffer-file-name (buffer-base-buffer))))
id)))))
(buffer-file-name (buffer-base-buffer)))))
id))))
;;;###autoload
(defun org-id-get-with-outline-path-completion (&optional targets)
@ -399,30 +449,6 @@ So a typical ID could look like \"Org:4nd91V40HI\"."
(t (error "Invalid `org-id-method'")))
(concat prefix unique)))
(defun org-id-uuid ()
"Return string with random (version 4) UUID."
(let ((rnd (md5 (format "%s%s%s%s%s%s%s"
(random)
(org-time-convert-to-list nil)
(user-uid)
(emacs-pid)
(user-full-name)
user-mail-address
(recent-keys)))))
(format "%s-%s-4%s-%s%s-%s"
(substring rnd 0 8)
(substring rnd 8 12)
(substring rnd 13 16)
(format "%x"
(logior
#b10000000
(logand
#b10111111
(string-to-number
(substring rnd 16 18) 16))))
(substring rnd 18 20)
(substring rnd 20 32))))
(defun org-id-int-to-b36-one-digit (integer)
"Convert INTEGER between 0 and 61 into a single character 0..9, A..Z, a..z."
(cond
@ -500,7 +526,6 @@ If SILENT is non-nil, messages are suppressed."
(interactive)
(unless org-id-track-globally
(error "Please turn on `org-id-track-globally' if you want to track IDs"))
(setq org-id-locations nil)
(let* ((files
(delete-dups
(mapcar #'file-truename
@ -524,11 +549,18 @@ If SILENT is non-nil, messages are suppressed."
(nfiles (length files))
(id-regexp
(rx (seq bol (0+ (any "\t ")) ":ID:" (1+ " ") (not (any " ")))))
(seen-ids nil)
(seen-ids (make-hash-table :test #'equal))
(ndup 0)
(i 0))
(with-temp-buffer
(org-element-with-disabled-cache
(i 0)
(checksum
(mapcar
(lambda (f)
(when (file-exists-p f)
(list f (file-attribute-modification-time (file-attributes f)))))
(sort (copy-sequence files) #'string<))))
(unless (equal checksum org-id--locations-checksum) ; Files have changed since the last update.
(setq org-id-locations nil)
(with-temp-buffer
(delay-mode-hooks
(org-mode)
(dolist (file files)
@ -538,29 +570,32 @@ If SILENT is non-nil, messages are suppressed."
(message "Finding ID locations (%d/%d files): %s" i nfiles file))
(insert-file-contents file nil nil nil 'replace)
(let ((ids nil)
node
(case-fold-search t))
(org-with-point-at 1
(while (re-search-forward id-regexp nil t)
(when (org-at-property-p)
(push (org-entry-get (point) "ID") ids)))
(setq node (org-element-at-point))
(when (org-element-type-p node 'node-property)
(push (org-element-property :value node) ids)))
(when ids
(push (cons (abbreviate-file-name file) ids)
org-id-locations)
(dolist (id ids)
(cond
((not (member id seen-ids)) (push id seen-ids))
((not (gethash id seen-ids)) (puthash id t seen-ids))
(silent nil)
(t
(message "Duplicate ID %S" id)
(cl-incf ndup))))))))))))
(setq org-id-files (mapcar #'car org-id-locations))
(org-id-locations-save)
;; Now convert to a hash table.
(setq org-id-locations (org-id-alist-to-hash org-id-locations))
(when (and (not silent) (> ndup 0))
(warn "WARNING: %d duplicate IDs found, check *Messages* buffer" ndup))
(message "%d files scanned, %d files contains IDs, and %d IDs found."
nfiles (length org-id-files) (hash-table-count org-id-locations))
(cl-incf ndup)))))))))))
(setq org-id-files (mapcar #'car org-id-locations))
(org-id-locations-save)
;; Now convert to a hash table.
(setq org-id-locations (org-id-alist-to-hash org-id-locations))
(setq org-id--locations-checksum checksum)
(when (and (not silent) (> ndup 0))
(warn "WARNING: %d duplicate IDs found, check *Messages* buffer" ndup))
(message "%d files scanned, %d files contains IDs, and %d IDs found."
nfiles (length org-id-files) (hash-table-count org-id-locations)))
org-id-locations))
(defun org-id-locations-save ()
@ -686,34 +721,81 @@ optional argument MARKERP, return the position as a new marker."
((not (file-exists-p file)) nil)
(t
(let* ((visiting (find-buffer-visiting file))
(buffer (or visiting (find-file-noselect file))))
(buffer (or visiting
(if markerp (find-file-noselect file)
(org-get-buffer-create " *Org ID temp*" t)))))
(unwind-protect
(with-current-buffer buffer
(unless (derived-mode-p 'org-mode) (org-mode))
(unless (or visiting markerp)
(buffer-disable-undo)
;; FIXME: In Emacs 27, `insert-file-contents' seemingly
;; does not trigger modification hooks in some
;; scenarios. This is manifested in test failures due
;; to element cache losing track of the modifications.
(org-element-cache-reset)
(insert-file-contents file nil nil nil 'replace))
(let ((pos (org-find-entry-with-id id)))
(cond
((null pos) nil)
(markerp (move-marker (make-marker) pos buffer))
(t (cons file pos)))))
;; Remove opened buffer in the process.
(unless (or visiting markerp) (kill-buffer buffer)))))))
;; Clean temporarily buffer if we don't need to keep it.
(unless (or visiting markerp)
(with-current-buffer buffer (erase-buffer))))))))
;; id link type
;; Calling the following function is hard-coded into `org-store-link',
;; so we do have to add it to `org-store-link-functions'.
(defun org-id--get-id-to-store-link (&optional create)
"Get or create the relevant ID for storing a link.
Optional argument CREATE is passed to `org-id-get'.
Inherited IDs are only considered when
`org-id-link-consider-parent-id', `org-id-link-use-context' and
`org-link-context-for-files' are all enabled, since inherited IDs
are confusing without the additional search string context.
Note that this function resets the
`org-entry-property-inherited-from' marker: it will either point
to nil (if the id was not inherited) or to the point it was
inherited from."
(let* ((inherit-id (and org-id-link-consider-parent-id
org-id-link-use-context
org-link-context-for-files)))
(move-marker org-entry-property-inherited-from nil)
(org-id-get nil create nil inherit-id)))
;;;###autoload
(defun org-id-store-link ()
"Store a link to the current entry, using its ID.
If before first heading store first title-keyword as description
or filename if no title."
The link description is based on the heading, or if before the
first heading, the title keyword if available, or else the
filename.
When `org-link-context-for-files' and `org-id-link-use-context'
are non-nil, add a search string to the link. The link
description is then based on the search string target.
When in addition `org-id-link-consider-parent-id' is non-nil, the
ID can be inherited from a parent entry, with the search string
used to still link to the current location."
(interactive)
(when (and (buffer-file-name (buffer-base-buffer)) (derived-mode-p 'org-mode))
(let* ((link (concat "id:" (org-id-get-create)))
(when (and (buffer-file-name (buffer-base-buffer))
(derived-mode-p 'org-mode))
;; Get the precise target first, in case looking for an id causes
;; a properties drawer to be added at the current location.
(let* ((precise-target (and org-link-context-for-files
org-id-link-use-context
(org-link-precise-link-target)))
(link (concat "id:" (org-id--get-id-to-store-link 'create)))
(id-location (or (and org-entry-property-inherited-from
(marker-position org-entry-property-inherited-from))
(save-excursion (org-back-to-heading-or-point-min t) (point))))
(case-fold-search nil)
(desc (save-excursion
(org-back-to-heading-or-point-min t)
(goto-char id-location)
(cond ((org-before-first-heading-p)
(let ((keywords (org-collect-keywords '("TITLE"))))
(if keywords
@ -725,14 +807,59 @@ or filename if no title."
(match-string 4)
(match-string 0)))
(t link)))))
;; Precise targets should be after id-location to avoid
;; duplicating the current headline as a search string
(when (and precise-target
(> (nth 2 precise-target) id-location))
(setq link (concat link "::" (nth 0 precise-target)))
(setq desc (nth 1 precise-target)))
(org-link-store-props :link link :description desc :type "id")
link)))
(defun org-id-open (id _)
"Go to the entry with id ID."
(org-mark-ring-push)
(let ((m (org-id-find id 'marker))
cmd)
;;;###autoload
(defun org-id-store-link-maybe (&optional interactive?)
"Store a link to the current entry using its ID if enabled.
The value of `org-id-link-to-org-use-id' determines whether an ID
link should be stored, using `org-id-store-link'.
Assume the function is called interactively if INTERACTIVE? is
non-nil."
(when (and (buffer-file-name (buffer-base-buffer))
(derived-mode-p 'org-mode)
(or (eq org-id-link-to-org-use-id t)
(and interactive?
(or (eq org-id-link-to-org-use-id 'create-if-interactive)
(and (eq org-id-link-to-org-use-id
'create-if-interactive-and-no-custom-id)
(not (org-entry-get nil "CUSTOM_ID")))))
;; 'use-existing
(and org-id-link-to-org-use-id
(org-id--get-id-to-store-link))))
(org-id-store-link)))
(defun org-id-open (link _)
"Go to the entry indicated by id link LINK.
The link can include a search string after \"::\", which is
passed to `org-link-search'.
For backwards compatibility with IDs that contain \"::\", if no
match is found for the ID, the full link string including \"::\"
will be tried as an ID."
(let* ((option (and (string-match "::\\(.*\\)\\'" link)
(match-string 1 link)))
(id (if (not option) link
(substring link 0 (match-beginning 0))))
m cmd)
(org-mark-ring-push)
(setq m (org-id-find id 'marker))
(when (and (not m) option)
;; Backwards compatibility: if id is not found, try treating
;; whole link as an id.
(setq m (org-id-find link 'marker))
(when m
(setq option nil)))
(unless m
(error "Cannot find entry with ID \"%s\"" id))
;; Use a buffer-switching command in analogy to finding files
@ -749,9 +876,17 @@ or filename if no title."
(funcall cmd (marker-buffer m)))
(goto-char m)
(move-marker m nil)
(when option
(save-restriction
(unless (org-before-first-heading-p)
(org-narrow-to-subtree))
(org-link-search option nil nil
(org-element-lineage (org-element-at-point) 'headline t))))
(org-fold-show-context)))
(org-link-set-parameters "id" :follow #'org-id-open)
(org-link-set-parameters "id"
:follow #'org-id-open
:store #'org-id-store-link-maybe)
(provide 'org-id)

15
lisp/org/org-indent.el
View file

@ -103,6 +103,14 @@ For details see the variable `org-adapt-indentation'."
:group 'org-indent
:type 'integer)
(defcustom org-indent-post-buffer-init-functions nil
"Hook run after org-indent finishes initializing a buffer.
The function(s) in in this hook must accept a single argument representing
the initialized buffer."
:group 'org-indent
:package-version '(Org . "9.7")
:type 'hook)
(defface org-indent '((t (:inherit org-hide)))
"Face for outline indentation.
The default is to make it look like whitespace. But you may find it
@ -290,7 +298,8 @@ a time value."
;; Job is complete: un-agentize buffer.
(unless interruptp
(setq org-indent-agentized-buffers
(delq buffer org-indent-agentized-buffers))))))))
(delq buffer org-indent-agentized-buffers))
(run-hook-with-args 'org-indent-post-buffer-init-functions buffer)))))))
(defun org-indent-set-line-properties (level indentation &optional heading)
"Set prefix properties on current line an move to next one.
@ -328,7 +337,7 @@ stopped."
(save-match-data
(org-with-wide-buffer
(goto-char beg)
(beginning-of-line)
(forward-line 0)
;; Initialize prefix at BEG, according to current entry's level.
(let* ((case-fold-search t)
(limited-re (org-get-limited-outline-regexp))
@ -410,7 +419,7 @@ This function is meant to be called by `after-change-functions'."
(if (or org-indent-modified-headline-flag
(save-excursion
(goto-char beg)
(beginning-of-line)
(forward-line 0)
(re-search-forward
(org-with-limited-levels org-outline-regexp-bol)
(save-excursion

13
lisp/org/org-inlinetask.el
View file

@ -94,9 +94,8 @@ Don't set it to something higher than `29' or clocking will break since this
is the hardcoded maximum number of stars `org-clock-sum' will work with.
It is strongly recommended that you set `org-cycle-max-level' not at all,
or to a number smaller than this one. In fact, when `org-cycle-max-level' is
not set, it will be assumed to be one less than the value of smaller than
the value of this variable."
or to a number smaller than this one. See `org-cycle-max-level'
docstring for more details."
:group 'org-inlinetask
:type '(choice
(const :tag "Off" nil)
@ -175,7 +174,7 @@ The number of levels is controlled by `org-inlinetask-min-level'."
(defun org-inlinetask-in-task-p ()
"Return true if point is inside an inline task."
(save-excursion
(beginning-of-line)
(forward-line 0)
(let ((case-fold-search t))
(or (looking-at-p (concat (org-inlinetask-outline-regexp) "\\(?:.*\\)"))
(and (re-search-forward "^\\*+[ \t]+" nil t)
@ -194,7 +193,7 @@ The number of levels is controlled by `org-inlinetask-min-level'."
"Go to the end of the inline task at point.
Return point."
(save-match-data
(beginning-of-line)
(forward-line 0)
(let ((case-fold-search t)
(inlinetask-re (org-inlinetask-outline-regexp)))
(cond
@ -242,7 +241,7 @@ going below `org-inlinetask-min-level'."
(replace-match down-task nil t nil 1)
(org-inlinetask-goto-end)
(if (and (eobp) (looking-back "END\\s-*" (line-beginning-position)))
(beginning-of-line)
(forward-line 0)
(forward-line -1))
(unless (= (point) beg)
(looking-at (org-inlinetask-outline-regexp))
@ -268,7 +267,7 @@ If the task has an end part, also demote it."
(replace-match down-task nil t nil 1)
(org-inlinetask-goto-end)
(if (and (eobp) (looking-back "END\\s-*" (line-beginning-position)))
(beginning-of-line)
(forward-line 0)
(forward-line -1))
(unless (= (point) beg)
(looking-at (org-inlinetask-outline-regexp))

160
lisp/org/org-keys.el
View file

@ -85,11 +85,26 @@
(declare-function org-down-element "org" ())
(declare-function org-edit-special "org" (&optional arg))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-emphasize "org" (&optional char))
(declare-function org-end-of-line "org" (&optional n))
(declare-function org-entry-put "org" (pom property value))
(declare-function org-eval-in-calendar "org" (form &optional keepdate))
(declare-function org-calendar-goto-today-or-insert-dot "org" ())
(declare-function org-calendar-goto-today "org" ())
(declare-function org-calendar-backward-month "org" ())
(declare-function org-calendar-forward-month "org" ())
(declare-function org-calendar-backward-year "org" ())
(declare-function org-calendar-forward-year "org" ())
(declare-function org-calendar-backward-week "org" ())
(declare-function org-calendar-forward-week "org" ())
(declare-function org-calendar-backward-day "org" ())
(declare-function org-calendar-forward-day "org" ())
(declare-function org-calendar-view-entries "org" ())
(declare-function org-calendar-scroll-month-left "org" ())
(declare-function org-calendar-scroll-month-right "org" ())
(declare-function org-calendar-scroll-three-months-left "org" ())
(declare-function org-calendar-scroll-three-months-right "org" ())
(declare-function org-evaluate-time-range "org" (&optional to-buffer))
(declare-function org-export-dispatch "org" (&optional arg))
(declare-function org-feed-goto-inbox "org" (feed))
@ -190,8 +205,8 @@
(declare-function org-table-sum "org" (&optional beg end nlast))
(declare-function org-table-toggle-coordinate-overlays "org" ())
(declare-function org-table-toggle-formula-debugger "org" ())
(declare-function org-time-stamp "org" (arg &optional inactive))
(declare-function org-time-stamp-inactive "org" (&optional arg))
(declare-function org-timestamp "org" (arg &optional inactive))
(declare-function org-timestamp-inactive "org" (&optional arg))
(declare-function org-timer "org" (&optional restart no-insert))
(declare-function org-timer-item "org" (&optional arg))
(declare-function org-timer-pause-or-continue "org" (&optional stop))
@ -210,7 +225,7 @@
(declare-function org-toggle-ordered-property "org" ())
(declare-function org-toggle-pretty-entities "org" ())
(declare-function org-toggle-tags-groups "org" ())
(declare-function org-toggle-time-stamp-overlays "org" ())
(declare-function org-toggle-timestamp-overlays "org" ())
(declare-function org-transpose-element "org" ())
(declare-function org-transpose-words "org" ())
(declare-function org-tree-to-indirect-buffer "org" (&optional arg))
@ -273,7 +288,7 @@ therefore you'll have to restart Emacs to apply it after changing."
(defcustom org-mouse-1-follows-link
(if (boundp 'mouse-1-click-follows-link) mouse-1-click-follows-link t)
"Non-nil means mouse-1 on a link will follow the link.
"Non-nil means Mouse-1 on a link will follow the link.
A longer mouse click will still set point. Needs to be set
before org.el is loaded."
:group 'org-link-follow
@ -298,7 +313,7 @@ implementation is bad."
:type 'hook)
(defcustom org-return-follows-link nil
"Non-nil means on links RET will follow the link.
"Non-nil means on links RET will open links, timestamps, and citations.
In tables, the special behavior of RET has precedence."
:group 'org-link-follow
:type 'boolean
@ -309,7 +324,7 @@ In tables, the special behavior of RET has precedence."
;;;; Base functions
(defun org-key (key)
"Select key according to `org-replace-disputed-keys' and `org-disputed-keys'.
"Select KEY according to `org-replace-disputed-keys' and `org-disputed-keys'.
Or return the original if not disputed."
(when org-replace-disputed-keys
(let* ((nkey (key-description key))
@ -319,7 +334,7 @@ Or return the original if not disputed."
key)
(defun org-defkey (keymap key def)
"Define a key, possibly translated, as returned by `org-key'."
"Define KEY, possibly translated, as returned by `org-key' in KEYMAP to DEF."
(define-key keymap (org-key key) def))
(defun org-remap (map &rest commands)
@ -349,71 +364,25 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names."
(defvar org-read-date-minibuffer-local-map
(let* ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
(org-defkey map (kbd ".")
(lambda () (interactive)
;; Are we at the beginning of the prompt?
(if (looking-back "^[^:]+: "
(let ((inhibit-field-text-motion t))
(line-beginning-position)))
(org-eval-in-calendar '(calendar-goto-today))
(insert "."))))
(org-defkey map (kbd "C-.")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-goto-today))))
(org-defkey map (kbd "M-S-<left>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-month 1))))
(org-defkey map (kbd "ESC S-<left>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-month 1))))
(org-defkey map (kbd "M-S-<right>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-month 1))))
(org-defkey map (kbd "ESC S-<right>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-month 1))))
(org-defkey map (kbd "M-S-<up>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-year 1))))
(org-defkey map (kbd "ESC S-<up>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-year 1))))
(org-defkey map (kbd "M-S-<down>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-year 1))))
(org-defkey map (kbd "ESC S-<down>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-year 1))))
(org-defkey map (kbd "S-<up>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-week 1))))
(org-defkey map (kbd "S-<down>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-week 1))))
(org-defkey map (kbd "S-<left>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-day 1))))
(org-defkey map (kbd "S-<right>")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-day 1))))
(org-defkey map (kbd "!")
(lambda () (interactive)
(org-eval-in-calendar '(diary-view-entries))
(message "")))
(org-defkey map (kbd ">")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-scroll-left 1))))
(org-defkey map (kbd "<")
(lambda () (interactive)
(org-eval-in-calendar '(calendar-scroll-right 1))))
(org-defkey map (kbd "C-v")
(lambda () (interactive)
(org-eval-in-calendar
'(calendar-scroll-left-three-months 1))))
(org-defkey map (kbd "M-v")
(lambda () (interactive)
(org-eval-in-calendar
'(calendar-scroll-right-three-months 1))))
(org-defkey map (kbd ".") #'org-calendar-goto-today-or-insert-dot)
(org-defkey map (kbd "C-.") #'org-calendar-goto-today)
(org-defkey map (kbd "M-S-<left>") #'org-calendar-backward-month)
(org-defkey map (kbd "ESC S-<left>") #'org-calendar-backward-month)
(org-defkey map (kbd "M-S-<right>") #'org-calendar-forward-month)
(org-defkey map (kbd "ESC S-<right>") #'org-calendar-forward-month)
(org-defkey map (kbd "M-S-<up>") #'org-calendar-backward-year)
(org-defkey map (kbd "ESC S-<up>") #'org-calendar-backward-year)
(org-defkey map (kbd "M-S-<down>") #'org-calendar-forward-year)
(org-defkey map (kbd "ESC S-<down>") #'org-calendar-forward-year)
(org-defkey map (kbd "S-<up>") #'org-calendar-backward-week)
(org-defkey map (kbd "S-<down>") #'org-calendar-forward-week)
(org-defkey map (kbd "S-<left>") #'org-calendar-backward-day)
(org-defkey map (kbd "S-<right>") #'org-calendar-forward-day)
(org-defkey map (kbd "!") #'org-calendar-view-entries)
(org-defkey map (kbd ">") #'org-calendar-scroll-month-left)
(org-defkey map (kbd "<") #'org-calendar-scroll-month-right)
(org-defkey map (kbd "C-v") #'org-calendar-scroll-three-months-left)
(org-defkey map (kbd "M-v") #'org-calendar-scroll-three-months-right)
map)
"Keymap for minibuffer commands when using `org-read-date'.")
@ -503,6 +472,7 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names."
(org-defkey org-mode-map (kbd "C-c C-x c") #'org-table-copy-down)
(org-defkey org-mode-map (kbd "C-c C-x m") #'org-meta-return)
(org-defkey org-mode-map (kbd "C-c C-x M") #'org-insert-todo-heading)
(org-defkey org-mode-map (kbd "C-c C-x s") #'org-insert-structure-template)
(org-defkey org-mode-map (kbd "C-c C-x RET") #'org-meta-return)
(org-defkey org-mode-map (kbd "ESC RET") #'org-meta-return)
(org-defkey org-mode-map (kbd "ESC <left>") #'org-metaleft)
@ -593,8 +563,8 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names."
(org-defkey org-mode-map (kbd "C-c %") #'org-mark-ring-push)
(org-defkey org-mode-map (kbd "C-c &") #'org-mark-ring-goto)
(org-defkey org-mode-map (kbd "C-c C-z") #'org-add-note) ;alternative binding
(org-defkey org-mode-map (kbd "C-c .") #'org-time-stamp) ;minor-mode reserved
(org-defkey org-mode-map (kbd "C-c !") #'org-time-stamp-inactive) ;minor-mode r.
(org-defkey org-mode-map (kbd "C-c .") #'org-timestamp) ;minor-mode reserved
(org-defkey org-mode-map (kbd "C-c !") #'org-timestamp-inactive) ;minor-mode r.
(org-defkey org-mode-map (kbd "C-c ,") #'org-priority) ;minor-mode reserved
(org-defkey org-mode-map (kbd "C-c C-y") #'org-evaluate-time-range)
(org-defkey org-mode-map (kbd "C-c >") #'org-goto-calendar)
@ -638,7 +608,7 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names."
(org-defkey org-mode-map (kbd "C-c C-x C-w") #'org-cut-special)
(org-defkey org-mode-map (kbd "C-c C-x M-w") #'org-copy-special)
(org-defkey org-mode-map (kbd "C-c C-x C-y") #'org-paste-special)
(org-defkey org-mode-map (kbd "C-c C-x C-t") #'org-toggle-time-stamp-overlays)
(org-defkey org-mode-map (kbd "C-c C-x C-t") #'org-toggle-timestamp-overlays)
(org-defkey org-mode-map (kbd "C-c C-x C-i") #'org-clock-in)
(org-defkey org-mode-map (kbd "C-c C-x C-x") #'org-clock-in-last)
(org-defkey org-mode-map (kbd "C-c C-x C-z") #'org-resolve-clocks)
@ -788,19 +758,21 @@ command."
(function)
(sexp))))))
(defun org-print-speed-command (e)
(if (> (length (car e)) 1)
(defun org--print-speed-command (speed-command)
"Print information about SPEED-COMMAND in help buffer.
SPEED-COMMAND is an element of `org-speed-commands'."
(if (> (length (car speed-command)) 1)
(progn
(princ "\n")
(princ (car e))
(princ (car speed-command))
(princ "\n")
(princ (make-string (length (car e)) ?-))
(princ (make-string (length (car speed-command)) ?-))
(princ "\n"))
(princ (car e))
(princ (car speed-command))
(princ " ")
(if (symbolp (cdr e))
(princ (symbol-name (cdr e)))
(prin1 (cdr e)))
(if (symbolp (cdr speed-command))
(princ (symbol-name (cdr speed-command)))
(prin1 (cdr speed-command)))
(princ "\n")))
(defun org-speed-command-help ()
@ -810,12 +782,7 @@ command."
(user-error "Speed commands are not activated, customize `org-use-speed-commands'"))
(with-output-to-temp-buffer "*Help*"
(princ "Speed commands\n==============\n")
(mapc #'org-print-speed-command
;; FIXME: don't check `org-speed-commands-user' past 9.6
(if (boundp 'org-speed-commands-user)
(append org-speed-commands
org-speed-commands-user)
org-speed-commands)))
(mapc #'org--print-speed-command org-speed-commands))
(with-current-buffer "*Help*"
(setq truncate-lines t)))
@ -831,16 +798,12 @@ If not, return to the original position and throw an error."
(defun org-speed-command-activate (keys)
"Hook for activating single-letter speed commands.
KEYS is the keys vector as returned by `this-command-keys-vector'.
See `org-speed-commands' for configuring them."
(when (or (and (bolp) (looking-at org-outline-regexp))
(and (functionp org-use-speed-commands)
(funcall org-use-speed-commands)))
(cdr (assoc keys
;; FIXME: don't check `org-speed-commands-user' past 9.6
(if (boundp 'org-speed-commands-user)
(append org-speed-commands
org-speed-commands-user)
org-speed-commands)))))
(cdr (assoc keys org-speed-commands))))
;;; Babel speed keys
@ -910,10 +873,11 @@ a-list placed behind the generic `org-babel-key-prefix'.")
(define-key org-babel-map key def))
(defun org-babel-speed-command-activate (keys)
"Hook for activating single-letter code block commands."
"Hook for activating single-letter code block commands.
KEYS is the keys vector as returned by `this-command-keys-vector'."
(when (and (bolp)
(let ((case-fold-search t)) (looking-at "[ \t]*#\\+begin_src"))
(eq 'src-block (org-element-type (org-element-at-point))))
(org-element-type-p (org-element-at-point) 'src-block))
(cdr (assoc keys org-babel-key-bindings))))
;;;###autoload

617
lisp/org/org-lint.el
View file

File diff suppressed because it is too large Load diff

394
lisp/org/org-list.el
View file

@ -111,15 +111,22 @@
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-lineage "org-element" (blob &optional types with-self))
(declare-function org-element-lineage "org-element-ast" (blob &optional types with-self))
(declare-function org-element-macro-interpreter "org-element" (macro ##))
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-normalize-string "org-element" (s))
(declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-put-property "org-element" (element property value))
(declare-function org-element-set-element "org-element" (old new))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only keep-deferred))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-contents-begin "org-element" (node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element-post-blank "org-element" (node))
(declare-function org-element-parent "org-element-ast" (node))
(declare-function org-element-put-property "org-element-ast" (node property value))
(declare-function org-element-set "org-element-ast" (old new))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-element-update-syntax "org-element" ())
(declare-function org-end-of-meta-data "org" (&optional full))
(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
@ -364,16 +371,32 @@ group 2: counter
group 3: checkbox
group 4: description tag")
(defun org-item-re ()
(defvar org--item-re-cache nil
"Results cache for `org-item-re'.")
(defsubst org-item-re ()
"Return the correct regular expression for plain lists."
(let ((term (cond
((eq org-plain-list-ordered-item-terminator t) "[.)]")
((= org-plain-list-ordered-item-terminator ?\)) ")")
((= org-plain-list-ordered-item-terminator ?.) "\\.")
(t "[.)]")))
(alpha (if org-list-allow-alphabetical "\\|[A-Za-z]" "")))
(concat "\\([ \t]*\\([-+]\\|\\(\\([0-9]+" alpha "\\)" term
"\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)")))
(or (plist-get
(plist-get org--item-re-cache
org-list-allow-alphabetical)
org-plain-list-ordered-item-terminator)
(let* ((term (cond
((eq org-plain-list-ordered-item-terminator t) "[.)]")
((= org-plain-list-ordered-item-terminator ?\)) ")")
((= org-plain-list-ordered-item-terminator ?.) "\\.")
(t "[.)]")))
(alpha (if org-list-allow-alphabetical "\\|[A-Za-z]" ""))
(re (concat "\\([ \t]*\\([-+]\\|\\(\\([0-9]+" alpha "\\)" term
"\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)")))
(setq org--item-re-cache
(plist-put
org--item-re-cache
org-list-allow-alphabetical
(plist-put
(plist-get org--item-re-cache
org-list-allow-alphabetical)
org-plain-list-ordered-item-terminator
re)))
re)))
(defsubst org-item-beginning-re ()
"Regexp matching the beginning of a plain list item."
@ -400,7 +423,7 @@ group 4: description tag")
(defun org-in-item-p ()
"Return item beginning position when in a plain list, nil otherwise."
(save-excursion
(beginning-of-line)
(forward-line 0)
(let* ((case-fold-search t)
(context (org-list-context))
(lim-up (car context))
@ -448,7 +471,7 @@ group 4: description tag")
(re-search-backward "^[ \t]*#\\+begin_" lim-up t)))
((and (looking-at "^[ \t]*:END:")
(re-search-backward org-drawer-regexp lim-up t))
(beginning-of-line))
(forward-line 0))
((and inlinetask-re (looking-at inlinetask-re))
(org-inlinetask-goto-beginning)
(forward-line -1))
@ -462,11 +485,18 @@ group 4: description tag")
(forward-line -1))
(t (forward-line -1)))))))))))
;; FIXME: We should make use of org-element API in more places here.
(defun org-at-item-p ()
"Is point in a line starting a hand-formatted item?"
"Is point in a line starting a hand-formatted item?
Modify match data, matching against `org-item-re'."
(save-excursion
(beginning-of-line)
(and (looking-at (org-item-re)) (org-list-in-valid-context-p))))
(forward-line 0)
(and
(org-element-type-p
(org-element-at-point)
'(plain-list item))
;; Set match data.
(looking-at (org-item-re)))))
(defun org-at-item-bullet-p ()
"Is point at the bullet of a plain list item?"
@ -508,7 +538,7 @@ Contexts `block' and `invalid' refer to `org-list-forbidden-blocks'."
(save-match-data
(save-excursion
(org-with-limited-levels
(beginning-of-line)
(forward-line 0)
(let ((case-fold-search t) (pos (point)) beg end context-type
;; Get positions of surrounding headings. This is the
;; default context.
@ -595,7 +625,7 @@ will get the following structure:
Assume point is at an item."
(save-excursion
(beginning-of-line)
(forward-line 0)
(let* ((case-fold-search t)
(context (org-list-context))
(lim-up (car context))
@ -663,7 +693,7 @@ Assume point is at an item."
(re-search-backward "^[ \t]*#\\+begin_" lim-up t)))
((and (looking-at "^[ \t]*:END:")
(re-search-backward org-drawer-regexp lim-up t))
(beginning-of-line))
(forward-line 0))
((and inlinetask-re (looking-at inlinetask-re))
(org-inlinetask-goto-beginning)
(forward-line -1))
@ -1122,7 +1152,7 @@ This function modifies STRUCT."
(org-fold-core-regions (cdr folds) :relative beg-A)
(org-fold-core-regions
(car folds)
:relative (+ beg-B (- size-B size-A (length between-A-no-blank-and-B))))
:relative (+ beg-A size-B (length between-A-no-blank-and-B)))
;; 2. Now modify struct. No need to re-read the list, the
;; transformation is just a shift of positions. Some special
;; attention is required for items ending at END-A and END-B
@ -1831,7 +1861,7 @@ Initial position of cursor is restored after the changes."
(lambda (end beg delta)
(goto-char end)
(skip-chars-backward " \r\t\n")
(beginning-of-line)
(forward-line 0)
(while (or (> (point) beg)
(and (= (point) beg)
(not (looking-at item-re))))
@ -2218,7 +2248,7 @@ item is invisible."
(setq struct (org-list-insert-item pos struct prevs checkbox desc))
(org-list-write-struct struct (org-list-parents-alist struct))
(when checkbox (org-update-checkbox-count-maybe))
(beginning-of-line)
(forward-line 0)
(looking-at org-list-full-item-re)
(goto-char (if (and (match-beginning 4)
(save-match-data
@ -2248,7 +2278,7 @@ is an integer, 0 means `-', 1 means `+' etc. If WHICH is
(interactive "P")
(unless (org-at-item-p) (error "Not at an item"))
(let ((origin (point-marker)))
(beginning-of-line)
(forward-line 0)
(let* ((struct (org-list-struct))
(parents (org-list-parents-alist struct))
(prevs (org-list-prevs-alist struct))
@ -2310,14 +2340,14 @@ is an integer, 0 means `-', 1 means `+' etc. If WHICH is
(setq struct (org-list-struct))
(cond
((>= origin-offset2 0)
(beginning-of-line)
(forward-line 0)
(move-marker origin (+ (point)
(org-list-get-ind (point) struct)
(length (org-list-get-bullet (point) struct))
origin-offset2))
(goto-char origin))
((>= origin-offset 0)
(beginning-of-line)
(forward-line 0)
(move-marker origin (+ (point)
(org-list-get-ind (point) struct)
origin-offset))
@ -2362,15 +2392,15 @@ is an integer, 0 means `-', 1 means `+' etc. If WHICH is
(defun org-at-radio-list-p ()
"Is point at a list item with radio buttons?"
(when (org-match-line (org-item-re)) ;short-circuit
(let* ((e (save-excursion (beginning-of-line) (org-element-at-point))))
(let* ((e (save-excursion (forward-line 0) (org-element-at-point))))
;; Check we're really on a line with a bullet.
(when (memq (org-element-type e) '(item plain-list))
(when (org-element-type-p e '(item plain-list))
;; Look for ATTR_ORG attribute in the current plain list.
(let ((plain-list (org-element-lineage e '(plain-list) t)))
(org-with-point-at (org-element-property :post-affiliated plain-list)
(let ((plain-list (org-element-lineage e 'plain-list t)))
(org-with-point-at (org-element-post-affiliated plain-list)
(let ((case-fold-search t)
(regexp "^[ \t]*#\\+attr_org:.* :radio \\(\\S-+\\)")
(begin (org-element-property :begin plain-list)))
(begin (org-element-begin plain-list)))
(and (re-search-backward regexp begin t)
(not (string-equal "nil" (match-string 1)))))))))))
@ -2408,7 +2438,7 @@ subtree, ignoring planning line and any drawer following it."
(setq lim-down (copy-marker limit))))
((org-at-heading-p)
;; On a heading, start at first item after drawers and
;; time-stamps (scheduled, etc.).
;; timestamps (scheduled, etc.).
(let ((limit (save-excursion (outline-next-heading) (point))))
(org-end-of-meta-data t)
(if (org-list-search-forward (org-item-beginning-re) limit t)
@ -2492,8 +2522,8 @@ subtree, ignoring planning line and any drawer following it."
(while (< (point) end)
(when (org-at-item-checkbox-p)
(replace-match "[ ]" t t nil 1))
(beginning-of-line 2)))
(org-update-checkbox-count-maybe 'all)))))
(forward-line 1)))
(org-update-checkbox-count-maybe 'narrow)))))
(defun org-update-checkbox-count (&optional all)
"Update the checkbox statistics in the current section.
@ -2501,126 +2531,131 @@ subtree, ignoring planning line and any drawer following it."
This will find all statistic cookies like [57%] and [6/12] and
update them with the current numbers.
With optional prefix argument ALL, do this for the whole buffer."
With optional prefix argument ALL, do this for the whole buffer.
When ALL is symbol `narrow', update statistics only in the accessible
portion of the buffer."
(interactive "P")
(org-with-wide-buffer
(let* ((cookie-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
(box-re "^[ \t]*\\([-+*]\\|\\([0-9]+\\|[A-Za-z]\\)[.)]\\)[ \t]+\
(save-excursion
(save-restriction
(unless (eq all 'narrow) (widen))
(let* ((cookie-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
(box-re "^[ \t]*\\([-+*]\\|\\([0-9]+\\|[A-Za-z]\\)[.)]\\)[ \t]+\
\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*\\)?\\(\\[[- X]\\]\\)")
(cookie-data (or (org-entry-get nil "COOKIE_DATA") ""))
(recursivep
(or (not org-checkbox-hierarchical-statistics)
(string-match-p "\\<recursive\\>" cookie-data)))
(within-inlinetask (and (not all)
(featurep 'org-inlinetask)
(org-inlinetask-in-task-p)))
(end (cond (all (point-max))
(within-inlinetask
(save-excursion (outline-next-heading) (point)))
(t (save-excursion
(org-with-limited-levels (outline-next-heading))
(point)))))
(count-boxes
(lambda (item structs recursivep)
;; Return number of checked boxes and boxes of all types
;; in all structures in STRUCTS. If RECURSIVEP is
;; non-nil, also count boxes in sub-lists. If ITEM is
;; nil, count across the whole structure, else count only
;; across subtree whose ancestor is ITEM.
(let ((c-on 0) (c-all 0))
(dolist (s structs (list c-on c-all))
(let* ((pre (org-list-prevs-alist s))
(par (org-list-parents-alist s))
(items
(cond
((and recursivep item) (org-list-get-subtree item s))
(recursivep (mapcar #'car s))
(item (org-list-get-children item s par))
(t (org-list-get-all-items
(org-list-get-top-point s) s pre))))
(cookies (delq nil (mapcar
(lambda (e)
(org-list-get-checkbox e s))
items))))
(cl-incf c-all (length cookies))
(cl-incf c-on (cl-count "[X]" cookies :test #'equal)))))))
cookies-list cache)
;; Move to start.
(cond (all (goto-char (point-min)))
(within-inlinetask (org-back-to-heading t))
(t (org-with-limited-levels (outline-previous-heading))))
;; Build an alist for each cookie found. The key is the position
;; at beginning of cookie and values ending position, format of
;; cookie, number of checked boxes to report and total number of
;; boxes.
(while (re-search-forward cookie-re end t)
(let ((context (save-excursion (backward-char)
(save-match-data (org-element-context)))))
(when (and (eq (org-element-type context) 'statistics-cookie)
(not (string-match-p "\\<todo\\>" cookie-data)))
(push
(append
(list (match-beginning 1) (match-end 1) (match-end 2))
(let* ((container
(org-element-lineage
context
'(drawer center-block dynamic-block inlinetask item
quote-block special-block verse-block)))
(beg (if container
(org-element-property :contents-begin container)
(save-excursion
(org-with-limited-levels
(outline-previous-heading))
(cookie-data (or (org-entry-get nil "COOKIE_DATA") ""))
(recursivep
(or (not org-checkbox-hierarchical-statistics)
(string-match-p "\\<recursive\\>" cookie-data)))
(within-inlinetask (and (not all)
(featurep 'org-inlinetask)
(org-inlinetask-in-task-p)))
(end (cond (all (point-max))
(within-inlinetask
(save-excursion (outline-next-heading) (point)))
(t (save-excursion
(org-with-limited-levels (outline-next-heading))
(point)))))
(or (cdr (assq beg cache))
(save-excursion
(goto-char beg)
(let ((end
(if container
(org-element-property :contents-end container)
(count-boxes
(lambda (item structs recursivep)
;; Return number of checked boxes and boxes of all types
;; in all structures in STRUCTS. If RECURSIVEP is
;; non-nil, also count boxes in sub-lists. If ITEM is
;; nil, count across the whole structure, else count only
;; across subtree whose ancestor is ITEM.
(let ((c-on 0) (c-all 0))
(dolist (s structs (list c-on c-all))
(let* ((pre (org-list-prevs-alist s))
(par (org-list-parents-alist s))
(items
(cond
((and recursivep item) (org-list-get-subtree item s))
(recursivep (mapcar #'car s))
(item (org-list-get-children item s par))
(t (org-list-get-all-items
(org-list-get-top-point s) s pre))))
(cookies (delq nil (mapcar
(lambda (e)
(org-list-get-checkbox e s))
items))))
(cl-incf c-all (length cookies))
(cl-incf c-on (cl-count "[X]" cookies :test #'equal)))))))
cookies-list cache)
;; Move to start.
(cond (all (goto-char (point-min)))
(within-inlinetask (org-back-to-heading t))
(t (org-with-limited-levels (outline-previous-heading))))
;; Build an alist for each cookie found. The key is the position
;; at beginning of cookie and values ending position, format of
;; cookie, number of checked boxes to report and total number of
;; boxes.
(while (re-search-forward cookie-re end t)
(let ((context (save-excursion (backward-char)
(save-match-data (org-element-context)))))
(when (and (org-element-type-p context 'statistics-cookie)
(not (string-match-p "\\<todo\\>" cookie-data)))
(push
(append
(list (match-beginning 1) (match-end 1) (match-end 2))
(let* ((container
(org-element-lineage
context
'(drawer center-block dynamic-block inlinetask item
quote-block special-block verse-block)))
(beg (if container
(org-element-contents-begin container)
(save-excursion
(org-with-limited-levels (outline-next-heading))
(point))))
structs)
(while (re-search-forward box-re end t)
(let ((element (org-element-at-point)))
(when (eq (org-element-type element) 'item)
(push (org-element-property :structure element)
structs)
;; Skip whole list since we have its
;; structure anyway.
(while (setq element (org-element-lineage
element '(plain-list)))
(goto-char
(min (org-element-property :end element)
end))))))
;; Cache count for cookies applying to the same
;; area. Then return it.
(let ((count
(funcall count-boxes
(and (eq (org-element-type container)
'item)
(org-element-property
:begin container))
structs
recursivep)))
(push (cons beg count) cache)
count))))))
cookies-list))))
;; Apply alist to buffer.
(dolist (cookie cookies-list)
(let* ((beg (car cookie))
(end (nth 1 cookie))
(percent (nth 2 cookie))
(checked (nth 3 cookie))
(total (nth 4 cookie)))
(goto-char beg)
(insert
(if percent (format "[%d%%]" (floor (* 100.0 checked)
(max 1 total)))
(format "[%d/%d]" checked total)))
(delete-region (point) (+ (point) (- end beg)))
(when org-auto-align-tags (org-fix-tags-on-the-fly)))))))
(org-with-limited-levels
(outline-previous-heading))
(point)))))
(or (cdr (assq beg cache))
(save-excursion
(goto-char beg)
(let ((end
(if container
(org-element-contents-end container)
(save-excursion
(org-with-limited-levels (outline-next-heading))
(point))))
structs)
(while (re-search-forward box-re end t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'item)
(push (org-element-property :structure element)
structs)
;; Skip whole list since we have its
;; structure anyway.
(while (setq element (org-element-lineage
element 'plain-list))
(goto-char
(min (org-element-end element)
end))))))
;; Cache count for cookies applying to the same
;; area. Then return it.
(let ((count
(funcall count-boxes
(and (org-element-type-p
container 'item)
(org-element-property
:begin container))
structs
recursivep)))
(push (cons beg count) cache)
count))))))
cookies-list))))
;; Apply alist to buffer.
(dolist (cookie cookies-list)
(let* ((beg (car cookie))
(end (nth 1 cookie))
(percent (nth 2 cookie))
(checked (nth 3 cookie))
(total (nth 4 cookie)))
(goto-char beg)
(org-fold-core-ignore-modifications
(insert-and-inherit
(if percent (format "[%d%%]" (floor (* 100.0 checked)
(max 1 total)))
(format "[%d/%d]" checked total)))
(delete-region (point) (+ (point) (- end beg))))
(when org-auto-align-tags (org-fix-tags-on-the-fly))))))))
(defun org-get-checkbox-statistics-face ()
"Select the face for checkbox statistics.
@ -2637,7 +2672,9 @@ Otherwise it will be `org-todo'."
(defun org-update-checkbox-count-maybe (&optional all)
"Update checkbox statistics unless turned off by user.
With an optional argument ALL, update them in the whole buffer."
With an optional argument ALL, update them in the whole buffer.
When ALL is symbol `narrow', update statistics only in the accessible
portion of the buffer."
(when (cdr (assq 'checkbox org-list-automatic-rules))
(org-update-checkbox-count all))
(run-hooks 'org-checkbox-statistics-hook))
@ -2688,7 +2725,8 @@ Return t if successful."
(no-subtree (1+ (line-beginning-position)))
(t (org-list-get-item-end (line-beginning-position) struct))))))
(let* ((beg (marker-position org-last-indent-begin-marker))
(end (marker-position org-last-indent-end-marker)))
(end (marker-position org-last-indent-end-marker))
(deactivate-mark nil))
(cond
;; Special case: moving top-item with indent rule.
(specialp
@ -2941,7 +2979,7 @@ function is being called interactively."
(error "Missing key extractor"))))
(sort-func
(cond
((= dcst ?a) #'string-collate-lessp)
((= dcst ?a) #'org-string<)
((= dcst ?f)
(or compare-func
(and interactive?
@ -2959,7 +2997,7 @@ function is being called interactively."
(now (current-time))
(next-record (lambda ()
(skip-chars-forward " \r\t\n")
(or (eobp) (beginning-of-line))))
(or (eobp) (forward-line 0))))
(end-record (lambda ()
(goto-char (org-list-get-item-end-before-blank
(point) struct))))
@ -3030,28 +3068,25 @@ With a prefix argument ARG, change the region in a single item."
(save-excursion
(while (re-search-forward org-footnote-definition-re end t)
(setq element (org-element-at-point))
(when (eq 'footnote-definition
(org-element-type element))
(when (org-element-type-p element 'footnote-definition)
(push (buffer-substring-no-properties
(org-element-property :begin element)
(org-element-property :end element))
(org-element-begin element)
(org-element-end element))
definitions)
;; Ensure at least 2 blank lines after the last
;; footnote definition, thus not slurping the
;; following element.
(unless (<= 2 (org-element-property
:post-blank
(org-element-at-point)))
(unless (<= 2 (org-element-post-blank
(org-element-at-point)))
(setf (car definitions)
(concat (car definitions)
(make-string
(- 2 (org-element-property
:post-blank
(- 2 (org-element-post-blank
(org-element-at-point)))
?\n))))
(delete-region
(org-element-property :begin element)
(org-element-property :end element))))
(org-element-begin element)
(org-element-end element))))
definitions))))
(shift-text
(lambda (ind end)
@ -3158,8 +3193,8 @@ With a prefix argument ARG, change the region in a single item."
"[X]"
"[ ]"))
(org-list-write-struct struct
(org-list-parents-alist struct)
old)))
(org-list-parents-alist struct)
old)))
;; Ensure all text down to END (or SECTION-END) belongs
;; to the newly created item.
(let ((section-end (save-excursion
@ -3171,7 +3206,7 @@ With a prefix argument ARG, change the region in a single item."
(when footnote-definitions
(goto-char end)
;; Insert footnote definitions after the list.
(unless (bolp) (beginning-of-line 2))
(unless (bolp) (forward-line 1))
;; At (point-max).
(unless (bolp) (insert "\n"))
(dolist (def footnote-definitions)
@ -3198,13 +3233,12 @@ With a prefix argument ARG, change the region in a single item."
(when footnote-definitions
;; If the new list is followed by same-level items,
;; move past them as well.
(goto-char (org-element-property
:end
(goto-char (org-element-end
(org-element-lineage
(org-element-at-point (1- end))
'(plain-list) t)))
'plain-list t)))
;; Insert footnote definitions after the list.
(unless (bolp) (beginning-of-line 2))
(unless (bolp) (forward-line 1))
;; At (point-max).
(unless (bolp) (insert "\n"))
(dolist (def footnote-definitions)
@ -3333,7 +3367,7 @@ Valid parameters are:
:backend, :raw
Export back-end used as a basis to transcode elements of the
Export backend used as a basis to transcode elements of the
list, when no specific parameter applies to it. It is also
used to translate its contents. You can prevent this by
setting :raw property to a non-nil value.
@ -3421,7 +3455,7 @@ Valid parameters are:
(if (consp e) (funcall insert-list e)
(insert e)
(insert "\n")))
(beginning-of-line)
(forward-line 0)
(save-excursion
(let ((ind (if (eq type 'ordered) 3 2)))
(while (> (point) start)
@ -3441,7 +3475,7 @@ Valid parameters are:
(when (and backend (plist-get params :raw))
(org-element-map data org-element-all-objects
(lambda (object)
(org-element-set-element
(org-element-set
object (org-element-interpret-data object)))))
;; We use a low-level mechanism to export DATA so as to skip all
;; usual pre-processing and post-processing, i.e., hooks, filters,
@ -3454,7 +3488,7 @@ Valid parameters are:
(defun org-list--depth (element)
"Return the level of ELEMENT within current plain list.
ELEMENT is either an item or a plain list."
(cl-count-if (lambda (ancestor) (eq (org-element-type ancestor) 'plain-list))
(cl-count-if (lambda (ancestor) (org-element-type-p ancestor 'plain-list))
(org-element-lineage element nil t)))
(defun org-list--trailing-newlines (string)
@ -3531,7 +3565,7 @@ PARAMS is a plist used to tweak the behavior of the transcoder."
(ddend (plist-get params :ddend)))
(lambda (item contents info)
(let* ((type
(org-element-property :type (org-element-property :parent item)))
(org-element-property :type (org-element-parent item)))
(tag (org-element-property :tag item))
(depth (org-list--depth item))
(separator (and (org-export-get-next-element item info)

40
lisp/org/org-macro.el
View file

@ -57,14 +57,17 @@
(declare-function org-collect-keywords "org" (keywords &optional unique directory))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-copy "org-element" (datum))
(declare-function org-element-copy "org-element-ast" (datum))
(declare-function org-element-macro-parser "org-element" ())
(declare-function org-element-keyword-parser "org-element" (limit affiliated))
(declare-function org-element-put-property "org-element" (element property value))
(declare-function org-element-put-property "org-element-ast" (node property value))
(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-restriction "org-element" (element))
(declare-function org-element-type "org-element" (element))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
(declare-function org-file-contents "org" (file &optional noerror nocache))
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance element))
@ -261,7 +264,7 @@ a definition in TEMPLATES."
(org-element-put-property macro :parent nil)
(let* ((key (org-element-property :key macro))
(value (org-macro-expand macro templates))
(begin (org-element-property :begin macro))
(begin (org-element-begin macro))
(signature (list begin
macro
(org-element-property :args macro))))
@ -275,7 +278,7 @@ a definition in TEMPLATES."
(delete-region
begin
;; Preserve white spaces after the macro.
(progn (goto-char (org-element-property :end macro))
(progn (goto-char (org-element-end macro))
(skip-chars-backward " \t")
(point)))
;; Leave point before replacement in case of
@ -337,14 +340,14 @@ Return a list of arguments, as strings. This is the opposite of
"Find PROPERTY's value at LOCATION.
PROPERTY is a string. LOCATION is a search string, as expected
by `org-link-search', or the empty string."
(save-excursion
(when (org-string-nw-p location)
(condition-case _
(let ((org-link-search-must-match-exact-headline t))
(org-link-search location nil t))
(error
(error "Macro property failed: cannot find location %s" location))))
(org-entry-get nil property 'selective)))
(org-with-wide-buffer
(when (org-string-nw-p location)
(condition-case _
(let ((org-link-search-must-match-exact-headline t))
(org-link-search location nil t))
(error
(error "Macro property failed: cannot find location %s" location))))
(org-entry-get nil property 'selective)))
(defun org-macro--find-keyword-value (name &optional collect)
"Find value for keyword NAME in current buffer.
@ -359,7 +362,7 @@ in the buffer."
(catch :exit
(while (re-search-forward regexp nil t)
(let ((element (org-with-point-at (match-beginning 0) (org-element-keyword-parser (line-end-position) (list (match-beginning 0))))))
(when (eq 'keyword (org-element-type element))
(when (org-element-type-p element 'keyword)
(let ((value (org-element-property :value element)))
(if (not collect) (throw :exit value)
(setq result (concat result " " value)))))))
@ -373,10 +376,13 @@ Return value as a string."
value (org-element-restriction 'keyword))))
(if (and (consp date)
(not (cdr date))
(eq 'timestamp (org-element-type (car date))))
(org-element-type-p (car date) 'timestamp))
(format "(eval (if (org-string-nw-p $1) %s %S))"
(format "(org-format-timestamp '%S $1)"
(org-element-copy (car date)))
(org-element-put-property
(org-element-copy (car date))
;; Remove non-printable.
:buffer nil))
value)
value)))

555
lisp/org/org-macs.el
View file

@ -113,16 +113,24 @@ Version mismatch is commonly encountered in the following situations:
(declare-function org-fold-next-visibility-change "org-fold" (&optional pos limit ignore-hidden-p previous-p))
(declare-function org-fold-core-with-forced-fontification "org-fold" (&rest body))
(declare-function org-fold-folded-p "org-fold" (&optional pos limit ignore-hidden-p previous-p))
(declare-function string-collate-lessp "org-compat" (s1 s2 &optional locale ignore-case))
(declare-function org-time-convert-to-integer "org-compat" (time))
(declare-function org-time-convert-to-list "org-compat" (time))
(declare-function org-buffer-text-pixel-width "org-compat" ())
(defvar org-ts-regexp0)
(defvar ffap-url-regexp)
(defvar org-fold-core-style)
;;; Macros
(defmacro org-require-package (symbol &optional name noerror)
"Try to load library SYMBOL and display error otherwise.
With optional parameter NAME, use NAME as package name instead of
SYMBOL. Show warning instead of error when NOERROR is non-nil."
`(unless (require ,symbol nil t)
(,(if noerror 'warn 'user-error)
"`%s' failed to load required package \"%s\""
this-command ,(or name symbol))))
(defmacro org-with-gensyms (symbols &rest body)
(declare (debug (sexp body)) (indent 1))
`(let ,(mapcar (lambda (s)
@ -151,19 +159,29 @@ If BUFFER is nil, use base buffer for `current-buffer'."
(or ,buffer (current-buffer)))
,@body))
(defmacro org-with-point-at (pom &rest body)
"Move to buffer and point of point-or-marker POM for the duration of BODY."
(defmacro org-with-point-at (epom &rest body)
"Move to buffer and point of EPOM for the duration of BODY.
EPOM is an element, point, or marker."
(declare (debug (form body)) (indent 1))
(org-with-gensyms (mpom)
`(let ((,mpom ,pom))
(require 'org-element-ast)
(org-with-gensyms (mepom)
`(let ((,mepom ,epom))
(save-excursion
(when (markerp ,mpom) (set-buffer (marker-buffer ,mpom)))
(cond
((markerp ,mepom)
(set-buffer (marker-buffer ,mepom)))
((numberp ,mepom))
(t
(when (org-element-property :buffer ,mepom)
(set-buffer (org-element-property :buffer ,mepom)))
(setq ,mepom (org-element-property :begin ,mepom))))
(org-with-wide-buffer
(goto-char (or ,mpom (point)))
(goto-char (or ,mepom (point)))
,@body)))))
(defmacro org-with-remote-undo (buffer &rest body)
"Execute BODY while recording undo information in two buffers."
"Execute BODY while recording undo information in current buffer and BUFFER.
This function is only useful when called from Agenda buffer."
(declare (debug (form body)) (indent 1))
(org-with-gensyms (cline cmd buf1 buf2 undo1 undo2 c1 c2)
`(let ((,cline (org-current-line))
@ -195,7 +213,7 @@ If BUFFER is nil, use base buffer for `current-buffer'."
(defalias 'org-save-outline-visibility #'org-fold-save-outline-visibility)
(defmacro org-with-wide-buffer (&rest body)
"Execute body while temporarily widening the buffer."
"Execute BODY while temporarily widening the buffer."
(declare (debug (body)))
`(save-excursion
(save-restriction
@ -213,7 +231,7 @@ If BUFFER is nil, use base buffer for `current-buffer'."
(let* ((org-called-with-limited-levels t)
(org-outline-regexp (org-get-limited-outline-regexp))
(outline-regexp org-outline-regexp)
(org-outline-regexp-bol (concat "^" org-outline-regexp)))
(org-outline-regexp-bol (org-get-limited-outline-regexp t)))
,@body)))
(defmacro org-eval-in-environment (environment form)
@ -249,11 +267,7 @@ If BUFFER is nil, use base buffer for `current-buffer'."
(unless modified
(restore-buffer-modified-p nil))))))))
(defmacro org-no-popups (&rest body)
"Suppress popup windows and evaluate BODY."
`(let (pop-up-frames pop-up-windows)
,@body))
;;;###autoload
(defmacro org-element-with-disabled-cache (&rest body)
"Run BODY without active org-element-cache."
(declare (debug (form body)) (indent 0))
@ -270,17 +284,36 @@ If BUFFER is nil, use base buffer for `current-buffer'."
buffer)))
(defun org-find-base-buffer-visiting (file)
"Like `find-buffer-visiting' but always return the base buffer and
not an indirect buffer."
"Like `find-buffer-visiting' but always return the base buffer.
FILE is the file name passed to `find-buffer-visiting'."
(let ((buf (or (get-file-buffer file)
(find-buffer-visiting file))))
(org-base-buffer buf)))
(defun org-switch-to-buffer-other-window (&rest args)
"Switch to buffer in a second window on the current frame.
In particular, do not allow pop-up frames.
Returns the newly created buffer."
(org-no-popups (apply #'switch-to-buffer-other-window args)))
(defvar-local org-file-buffer-created nil
"Non-nil when current buffer is created from `org-with-file-buffer'.
The value is FILE argument passed to `org-with-file-buffer'.")
(defmacro org-with-file-buffer (file &rest body)
"Evaluate BODY with current buffer visiting FILE.
When no live buffer is visiting FILE, create one and kill after
evaluating BODY.
During evaluation, when the buffer was created, `org-file-buffer-created'
variable is set to FILE."
(declare (debug (form body)) (indent 1))
(org-with-gensyms (mark-function filename buffer)
`(let ((,mark-function (lambda () (setq-local org-file-buffer-created ,file)))
(,filename ,file)
,buffer)
(add-hook 'find-file-hook ,mark-function)
(unwind-protect
(progn
(setq ,buffer (find-file-noselect ,filename t))
(with-current-buffer ,buffer
(prog1 (progn ,@body)
(with-current-buffer ,buffer
(when (equal ,filename org-file-buffer-created)
(kill-buffer))))))
(remove-hook 'find-file-hook ,mark-function)))))
(defun org-fit-window-to-buffer (&optional window max-height min-height
shrink-only)
@ -358,72 +391,6 @@ in target-prerequisite files relation."
(let ((mtime (file-attribute-modification-time (file-attributes file))))
(and mtime (or (not time) (time-less-p time mtime)))))
(defun org-compile-file (source process ext &optional err-msg log-buf spec)
"Compile a SOURCE file using PROCESS.
PROCESS is either a function or a list of shell commands, as
strings. EXT is a file extension, without the leading dot, as
a string. It is used to check if the process actually succeeded.
PROCESS must create a file with the same base name and directory
as SOURCE, but ending with EXT. The function then returns its
filename. Otherwise, it raises an error. The error message can
then be refined by providing string ERR-MSG, which is appended to
the standard message.
If PROCESS is a function, it is called with a single argument:
the SOURCE file.
If it is a list of commands, each of them is called using
`shell-command'. By default, in each command, %b, %f, %F, %o and
%O are replaced with, respectively, SOURCE base name, name, full
name, directory and absolute output file name. It is possible,
however, to use more place-holders by specifying them in optional
argument SPEC, as an alist following the pattern
(CHARACTER . REPLACEMENT-STRING).
When PROCESS is a list of commands, optional argument LOG-BUF can
be set to a buffer or a buffer name. `shell-command' then uses
it for output."
(let* ((base-name (file-name-base source))
(full-name (file-truename source))
(relative-name (file-relative-name source))
(out-dir (if (file-name-directory source)
;; Expand "~". Shell expansion will be disabled
;; in the shell command call.
(file-name-directory full-name)
"./"))
(output (expand-file-name (concat base-name "." ext) out-dir))
(time (file-attribute-modification-time (file-attributes output)))
(err-msg (if (stringp err-msg) (concat ". " err-msg) "")))
(save-window-excursion
(pcase process
((pred functionp) (funcall process (shell-quote-argument relative-name)))
((pred consp)
(let ((log-buf (and log-buf (get-buffer-create log-buf)))
(spec (append spec
`((?b . ,(shell-quote-argument base-name))
(?f . ,(shell-quote-argument relative-name))
(?F . ,(shell-quote-argument full-name))
(?o . ,(shell-quote-argument out-dir))
(?O . ,(shell-quote-argument output))))))
;; Combine output of all commands in PROCESS.
(with-current-buffer log-buf
(let (buffer-read-only)
(erase-buffer)))
(let ((shell-command-dont-erase-buffer t))
(dolist (command process)
(shell-command (format-spec command spec) log-buf)))
(when log-buf (with-current-buffer log-buf (compilation-mode)))))
(_ (error "No valid command to process %S%s" source err-msg))))
;; Check for process failure. Output file is expected to be
;; located in the same directory as SOURCE.
(unless (org-file-newer-than-p output time)
(error (format "File %S wasn't produced%s" output err-msg)))
output))
;;; Indentation
@ -434,6 +401,8 @@ it for output."
(defun org-do-remove-indentation (&optional n skip-fl)
"Remove the maximum common indentation from the buffer.
Do not consider invisible text when calculating indentation.
When optional argument N is a positive integer, remove exactly
that much characters from indentation, if possible. When
optional argument SKIP-FL is non-nil, skip the first
@ -454,10 +423,14 @@ line. Return nil if it fails."
;; Remove exactly N indentation, but give up if not possible.
(when skip-fl (forward-line))
(while (not (eobp))
(let ((ind (progn (skip-chars-forward " \t") (current-column))))
(cond ((eolp) (delete-region (line-beginning-position) (point)))
((< ind n) (throw :exit nil))
(t (indent-line-to (- ind n))))
(let* ((buffer-invisibility-spec nil) ; do not treat invisible text specially
(ind (progn (skip-chars-forward " \t") (current-column))))
(cond ((< ind n)
(if (eolp) (delete-region (line-beginning-position) (point))
(throw :exit nil)))
(t (delete-region (line-beginning-position)
(progn (move-to-column n t)
(point)))))
(forward-line)))
;; Signal success.
t))))
@ -476,7 +449,7 @@ error when the user input is empty."
(allow-empty? nil)
(t (user-error "Empty input is not valid")))))
(declare-function org-time-stamp-inactive "org" (&optional arg))
(declare-function org-timestamp-inactive "org" (&optional arg))
(defun org-completing-read (&rest args)
"Completing-read with SPACE being a normal character."
@ -486,7 +459,7 @@ error when the user input is empty."
(define-key minibuffer-local-completion-map " " #'self-insert-command)
(define-key minibuffer-local-completion-map "?" #'self-insert-command)
(define-key minibuffer-local-completion-map (kbd "C-c !")
#'org-time-stamp-inactive)
#'org-timestamp-inactive)
(apply #'completing-read args)))
(defun org--mks-read-key (allowed-keys prompt navigation-keys)
@ -535,7 +508,7 @@ alist with (\"key\" \"description\") entries. When one of these
is selected, only the bare key is returned."
(save-window-excursion
(let ((inhibit-quit t)
(buffer (org-switch-to-buffer-other-window "*Org Select*"))
(buffer (switch-to-buffer-other-window "*Org Select*"))
(prompt (or prompt "Select: "))
case-fold-search
current)
@ -599,7 +572,10 @@ is selected, only the bare key is returned."
;; selection prefix.
((assoc current specials) (throw 'exit current))
(t (error "No entry available")))))))
(when buffer (kill-buffer buffer))))))
(when buffer
(when-let ((window (get-buffer-window buffer t)))
(quit-window 'kill window))
(kill-buffer buffer))))))
;;; List manipulation
@ -781,46 +757,100 @@ get an unnecessary O(N²) space complexity, so you're usually better off using
(defun org-eval (form)
"Eval FORM and return result."
(condition-case error
(condition-case-unless-debug error
(eval form t)
(error (format "%%![Error: %s]" error))))
(defvar org--headline-re-cache-no-bol nil
"Plist holding association between headline level regexp.")
(defvar org--headline-re-cache-bol nil
"Plist holding association between headline level regexp.")
(defsubst org-headline-re (true-level &optional no-bol)
"Generate headline regexp for TRUE-LEVEL.
When NO-BOL is non-nil, regexp will not demand the regexp to start at
beginning of line."
(or (plist-get
(if no-bol
org--headline-re-cache-no-bol
org--headline-re-cache-bol)
true-level)
(let ((re (rx-to-string
(if no-bol
`(seq (** 1 ,true-level "*") " ")
`(seq line-start (** 1 ,true-level "*") " ")))))
(if no-bol
(setq org--headline-re-cache-no-bol
(plist-put
org--headline-re-cache-no-bol
true-level re))
(setq org--headline-re-cache-bol
(plist-put
org--headline-re-cache-bol
true-level re)))
re)))
(defvar org-outline-regexp) ; defined in org.el
(defvar org-outline-regexp-bol) ; defined in org.el
(defvar org-odd-levels-only) ; defined in org.el
(defvar org-inlinetask-min-level) ; defined in org-inlinetask.el
(defun org-get-limited-outline-regexp ()
(defun org-get-limited-outline-regexp (&optional with-bol)
"Return outline-regexp with limited number of levels.
The number of levels is controlled by `org-inlinetask-min-level'."
The number of levels is controlled by `org-inlinetask-min-level'.
Match at beginning of line when WITH-BOL is non-nil."
(cond ((not (derived-mode-p 'org-mode))
outline-regexp)
(if (string-prefix-p "^" outline-regexp)
(if with-bol outline-regexp (substring outline-regexp 1))
(if with-bol (concat "^" outline-regexp) outline-regexp)))
((not (featurep 'org-inlinetask))
org-outline-regexp)
(if with-bol org-outline-regexp-bol org-outline-regexp))
(t
(let* ((limit-level (1- org-inlinetask-min-level))
(nstars (if org-odd-levels-only
(1- (* limit-level 2))
limit-level)))
(format "\\*\\{1,%d\\} " nstars)))))
(org-headline-re nstars (not with-bol))))))
(defun org--line-empty-p (n)
"Is the Nth next line empty?
Counts the current line as N = 1 and the previous line as N = 0;
see `beginning-of-line'."
"Is the Nth next line empty?"
(and (not (bobp))
(save-excursion
(beginning-of-line n)
(looking-at-p "[ \t]*$"))))
(forward-line n)
(skip-chars-forward "[ \t]")
(eolp))))
(defun org-previous-line-empty-p ()
"Is the previous line a blank line?
When NEXT is non-nil, check the next line instead."
(org--line-empty-p 0))
(org--line-empty-p -1))
(defun org-next-line-empty-p ()
"Is the previous line a blank line?
When NEXT is non-nil, check the next line instead."
(org--line-empty-p 2))
(org--line-empty-p 1))
(defun org-id-uuid ()
"Return string with random (version 4) UUID."
(let ((rnd (md5 (format "%s%s%s%s%s%s%s"
(random)
(org-time-convert-to-list nil)
(user-uid)
(emacs-pid)
(user-full-name)
user-mail-address
(recent-keys)))))
(format "%s-%s-4%s-%s%s-%s"
(substring rnd 0 8)
(substring rnd 8 12)
(substring rnd 13 16)
(format "%x"
(logior
#b10000000
(logand
#b10111111
(string-to-number
(substring rnd 16 18) 16))))
(substring rnd 18 20)
(substring rnd 20 32))))
;;; Motion
@ -887,14 +917,14 @@ Return nil when PROP is not set at POS."
(<= (match-beginning n) pos)
(>= (match-end n) pos)))
(defun org-skip-whitespace ()
(defsubst org-skip-whitespace ()
"Skip over space, tabs and newline characters."
(skip-chars-forward " \t\n\r"))
(defun org-match-line (regexp)
"Match REGEXP at the beginning of the current line."
(save-excursion
(beginning-of-line)
(forward-line 0)
(looking-at regexp)))
(defun org-match-any-p (re list)
@ -916,7 +946,7 @@ match."
(let ((pos (point))
(eol (line-end-position (if nlines (1+ nlines) 1))))
(save-excursion
(beginning-of-line (- 1 (or nlines 0)))
(forward-line (- (or nlines 0)))
(while (and (re-search-forward regexp eol t)
(<= (match-beginning 0) pos))
(let ((end (match-end 0)))
@ -940,23 +970,79 @@ return nil."
(require 'ffap)
(and ffap-url-regexp (string-match-p ffap-url-regexp s)))
(defconst org-uuid-regexp
"\\`[0-9a-f]\\{8\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{12\\}\\'"
"Regular expression matching a universal unique identifier (UUID).")
(defun org-uuidgen-p (s)
"Is S an ID created by UUIDGEN?"
(string-match org-uuid-regexp (downcase s)))
;;; String manipulation
(defun org-string< (a b)
(string-collate-lessp a b))
(defcustom org-sort-function #'string-collate-lessp
"Function used to compare strings when sorting.
This function affects how Org mode sorts headlines, agenda items,
table lines, etc.
(defun org-string<= (a b)
(or (string= a b) (string-collate-lessp a b)))
The function must accept either 2 or 4 arguments: strings to compare
and, optionally, LOCALE and IGNORE-CASE - locale name and flag to make
comparison case-insensitive.
(defun org-string>= (a b)
(not (string-collate-lessp a b)))
The default value uses sorting rules according to OS language. Users
who want to make sorting language-independent, may customize the value
to `org-sort-function-fallback'.
(defun org-string> (a b)
Note that some string sorting rules are known to be not accurate on
MacOS. See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=59275.
MacOS users may customize the value to
`org-sort-function-fallback'."
:group 'org
:package-version '(Org . "9.7")
:type '(choice
(const :tag "According to OS language" string-collate-lessp)
(const :tag "Using string comparison" org-sort-function-fallback)
(function :tag "Custom function")))
(defun org-sort-function-fallback (a b &optional _ ignore-case)
"Return non-nil when downcased string A < string B.
Use `compare-strings' for comparison. Honor IGNORE-CASE."
(let ((ans (compare-strings a nil nil b nil nil ignore-case)))
(cond
((and (numberp ans) (< ans 0)) t)
(t nil))))
(defun org-string< (a b &optional locale ignore-case)
"Return non-nil when string A < string B.
LOCALE is the locale name. IGNORE-CASE, when non-nil, makes comparison
ignore case."
(if (= 4 (cdr (func-arity org-sort-function)))
(funcall org-sort-function a b locale ignore-case)
(funcall org-sort-function a b)))
(defun org-string<= (a b &optional locale ignore-case)
"Return non-nil when string A <= string B.
LOCALE is the locale name. IGNORE-CASE, when non-nil, makes comparison
ignore case."
(or (string= a b) (org-string< a b locale ignore-case)))
(defun org-string>= (a b &optional locale ignore-case)
"Return non-nil when string A >= string B.
LOCALE is the locale name. IGNORE-CASE, when non-nil, makes comparison
ignore case."
(not (org-string< a b locale ignore-case)))
(defun org-string> (a b &optional locale ignore-case)
"Return non-nil when string A > string B.
LOCALE is the locale name. IGNORE-CASE, when non-nil, makes comparison
ignore case."
(and (not (string= a b))
(not (string-collate-lessp a b))))
(not (org-string< a b locale ignore-case))))
(defun org-string<> (a b)
"Return non-nil when string A and string B are not equal."
(not (string= a b)))
(defsubst org-trim (s &optional keep-lead)
@ -1065,9 +1151,11 @@ Results may be off sometimes if it cannot handle a given
`display' value."
(org--string-from-props string 'display 0 (length string)))
(defun org-string-width (string &optional pixels)
(defun org-string-width (string &optional pixels default-face)
"Return width of STRING when displayed in the current buffer.
Return width in pixels when PIXELS is non-nil."
Return width in pixels when PIXELS is non-nil.
When PIXELS is nil, DEFAULT-FACE is the face used to calculate relative
STRING width. When REFERENCE-FACE is nil, `default' face is used."
(if (and (version< emacs-version "28") (not pixels))
;; FIXME: Fallback to old limited version, because
;; `window-pixel-width' is buggy in older Emacs.
@ -1082,7 +1170,7 @@ Return width in pixels when PIXELS is non-nil."
;; is critical to get right string width from pixel width (not needed
;; when PIXELS are requested though).
(unless pixels
(remove-text-properties 0 (length string) '(face t) string))
(put-text-property 0 (length string) 'face (or default-face 'default) string))
(let (;; We need to remove the folds to make sure that folded table
;; alignment is not messed up.
(current-invisibility-spec
@ -1102,8 +1190,10 @@ Return width in pixels when PIXELS is non-nil."
(push el result)))
result)))
(current-char-property-alias-alist char-property-alias-alist))
(with-temp-buffer
(with-current-buffer (get-buffer-create " *Org string width*")
(setq-local display-line-numbers nil)
(setq-local line-prefix nil)
(setq-local wrap-prefix nil)
(setq-local buffer-invisibility-spec
(if (listp current-invisibility-spec)
(mapcar (lambda (el)
@ -1121,52 +1211,26 @@ Return width in pixels when PIXELS is non-nil."
(with-silent-modifications
(erase-buffer)
(insert string)
(setq pixel-width
(if (get-buffer-window (current-buffer))
(car (window-text-pixel-size
;; FIXME: 10000 because
;; `most-positive-fixnum' ain't working
;; (tests failing) and this call will be
;; removed after we drop Emacs 28 support
;; anyway.
nil (line-beginning-position) (point-max) 10000))
(let ((dedicatedp (window-dedicated-p))
(oldbuffer (window-buffer)))
(unwind-protect
(progn
;; Do not throw error in dedicated windows.
(set-window-dedicated-p nil nil)
(set-window-buffer nil (current-buffer))
(car (window-text-pixel-size
nil (line-beginning-position) (point-max) 10000)))
(set-window-buffer nil oldbuffer)
(set-window-dedicated-p nil dedicatedp)))))
(setq pixel-width (org-buffer-text-pixel-width))
(unless pixels
(erase-buffer)
(insert "a")
(setq symbol-width
(if (get-buffer-window (current-buffer))
(car (window-text-pixel-size
nil (line-beginning-position) (point-max) 10000))
(let ((dedicatedp (window-dedicated-p))
(oldbuffer (window-buffer)))
(unwind-protect
(progn
;; Do not throw error in dedicated windows.
(set-window-dedicated-p nil nil)
(set-window-buffer nil (current-buffer))
(car (window-text-pixel-size
nil (line-beginning-position) (point-max) 10000)))
(set-window-buffer nil oldbuffer)
(set-window-dedicated-p nil dedicatedp)))))))
(insert (propertize "a" 'face (or default-face 'default)))
(setq symbol-width (org-buffer-text-pixel-width))))
(if pixels
pixel-width
(/ pixel-width symbol-width)))))))
(ceiling pixel-width symbol-width)))))))
(defmacro org-current-text-column ()
"Like `current-column' but ignore display properties."
`(string-width (buffer-substring-no-properties
(line-beginning-position) (point))))
"Like `current-column' but ignore display properties.
Throw an error when `tab-width' is not 8.
This function forces `tab-width' value because it is used as a part of
the parser, to ensure parser consistency when calculating list
indentation."
`(progn
(unless (= 8 tab-width) (error "Tab width in Org files must be 8, not %d. Please adjust your `tab-width' settings for Org mode." tab-width))
(string-width (buffer-substring-no-properties
(line-beginning-position) (point)))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
@ -1227,6 +1291,10 @@ Assumes that s is a single line, starting in column 0."
t t s)))
s)
(defun org-remove-blank-lines (s)
"Remove blank lines in S."
(replace-regexp-in-string (rx "\n" (1+ (0+ space) "\n")) "\n" s))
(defun org-wrap (string &optional width lines)
"Wrap string to either a number of lines, or a width in characters.
If WIDTH is non-nil, the string is wrapped to that width, however many lines
@ -1553,6 +1621,9 @@ Return 0. if S is not recognized as a valid value."
((string-match org-ts-regexp0 s) (org-2ft s))
(t 0.)))))
;;; Misc
(defun org-scroll (key &optional additional-keys)
"Receive KEY and scroll the current window accordingly.
When ADDITIONAL-KEYS is not nil, also include SPC and DEL in the
@ -1589,6 +1660,158 @@ Credit: https://stackoverflow.com/questions/11871245/knuth-multiplicative-hash#4
(cl-assert (and (<= 0 base 32)))
(ash (* number 2654435769) (- base 32)))
(defvar org-sxhash-hashes (make-hash-table :weakness 'key :test 'equal))
(defvar org-sxhash-objects (make-hash-table :weakness 'value))
(defun org-sxhash-safe (obj &optional counter)
"Like `sxhash' for OBJ, but collision-free for in-memory objects.
When COUNTER is non-nil, return safe hash for (COUNTER . OBJ)."
;; Note: third-party code may modify OBJ by side effect.
;; Should not affect anything as long as `org-sxhash-safe'
;; is used to calculate hash.
(or (and (not counter) (gethash obj org-sxhash-hashes))
(let* ((hash (sxhash (if counter (cons counter obj) obj)))
(obj-old (gethash hash org-sxhash-objects)))
(if obj-old ; collision
(org-sxhash-safe obj (if counter (1+ counter) 1))
;; No collision. Remember and return normal hash.
(puthash hash obj org-sxhash-objects)
(puthash obj hash org-sxhash-hashes)))))
(defun org-compile-file (source process ext &optional err-msg log-buf spec)
"Compile a SOURCE file using PROCESS.
See `org-compile-file-commands' for information on PROCESS, EXT, and SPEC.
If PROCESS fails, an error will be raised. The error message can
then be refined by providing string ERR-MSG, which is appended to
the standard message.
PROCESS must create a file with the same base name and directory
as SOURCE, but ending with EXT. The function then returns its
filename. Otherwise, it raises an error.
When PROCESS is a list of commands, optional argument LOG-BUF can
be set to a buffer or a buffer name. `shell-command' then uses
it for output."
(let* ((commands (org-compile-file-commands source process ext spec err-msg))
(output (concat (file-name-sans-extension source) "." ext))
;; Resolve symlinks in default-directory to correctly handle
;; absolute source paths or relative paths with ..
(relname (if (file-name-absolute-p source)
(let ((pwd (file-truename default-directory)))
(file-relative-name source pwd))
source))
(log-buf (and log-buf (get-buffer-create log-buf)))
(time (file-attribute-modification-time (file-attributes output))))
(save-window-excursion
(dolist (command commands)
(cond
((functionp command)
(funcall command (shell-quote-argument relname)))
((stringp command)
(let ((shell-command-dont-erase-buffer t))
(shell-command command log-buf))))))
;; Check for process failure. Output file is expected to be
;; located in the same directory as SOURCE.
(unless (org-file-newer-than-p output time)
(ignore (defvar org-batch-test))
;; Display logs when running tests.
(when (bound-and-true-p org-batch-test)
(message "org-compile-file log ::\n-----\n%s\n-----\n"
(with-current-buffer log-buf (buffer-string))))
(error
(format
"File %S wasn't produced%s"
output
(if (org-string-nw-p err-msg)
(concat " " (org-trim err-msg))
err-msg))))
output))
(defun org-compile-file-commands (source process ext &optional spec err-msg)
"Return list of commands used to compile SOURCE file.
The commands are formed from PROCESS, which is either a function or
a list of shell commands, as strings. EXT is a file extension, without
the leading dot, as a string. After PROCESS has been executed,
a file with the same basename and directory as SOURCE but with the
file extension EXT is expected to be produced.
Failure to produce this file will be interpreted as PROCESS failing.
If PROCESS is a function, it is called with a single argument:
the SOURCE file.
If PROCESS is a list of commands, each of them is called using
`shell-command'. By default, in each command, %b, %f, %F, %o and
%O are replaced with, respectively, SOURCE base name, relative
file name, absolute file name, relative directory and absolute
output file name. It is possible, however, to use more
place-holders by specifying them in optional argument SPEC, as an
alist following the pattern
(CHARACTER . REPLACEMENT-STRING).
Throw an error if PROCESS does not satisfy the described patterns.
The error string will be appended with ERR-MSG, when it is a string."
(let* ((basename (file-name-base source))
;; Resolve symlinks in default-directory to correctly handle
;; absolute source paths or relative paths with ..
(pwd (file-truename default-directory))
(absname (expand-file-name source pwd))
(relname (if (file-name-absolute-p source)
(file-relative-name source pwd)
source))
(relpath (or (file-name-directory relname) "./"))
(output (concat (file-name-sans-extension absname) "." ext))
(err-msg (if (stringp err-msg) (concat ". " err-msg) "")))
(pcase process
((pred functionp) (list process))
((pred consp)
(let ((spec (append spec
`((?b . ,(shell-quote-argument basename))
(?f . ,(shell-quote-argument relname))
(?F . ,(shell-quote-argument absname))
(?o . ,(shell-quote-argument relpath))
(?O . ,(shell-quote-argument output))))))
(mapcar (lambda (command) (format-spec command spec)) process)))
(_ (error "No valid command to process %S%s" source err-msg)))))
(defun org-display-buffer-split (buffer alist)
"Display BUFFER in the current frame split in two parts.
The frame will display two buffers - current buffer and BUFFER.
ALIST is an association list of action symbols and values. See
Info node `(elisp) Buffer Display Action Alists' for details of
such alists.
Use `display-buffer-in-direction' internally.
This is an action function for buffer display, see Info
node `(elisp) Buffer Display Action Functions'. It should be
called only by `display-buffer' or a function directly or
indirectly called by the latter."
(let ((window-configuration (current-window-configuration)))
(ignore-errors (delete-other-windows))
(or (display-buffer-in-direction buffer alist)
(display-buffer-pop-up-window buffer alist)
(prog1 nil
(set-window-configuration window-configuration)))))
(defun org-display-buffer-in-window (buffer alist)
"Display BUFFER in specific window.
The window is defined according to the `window' slot in the ALIST.
Then `same-frame' slot in the ALIST is set, only display buffer when
window is present in the current frame.
This is an action function for buffer display, see Info
node `(elisp) Buffer Display Action Functions'. It should be
called only by `display-buffer' or a function directly or
indirectly called by the latter."
(let ((window (alist-get 'window alist)))
(when (and window
(window-live-p window)
(or (not (alist-get 'same-frame alist))
(eq (window-frame) (window-frame window))))
(window--display-buffer buffer window 'reuse alist))))
(provide 'org-macs)
;; Local variables:

14
lisp/org/org-mobile.el
View file

@ -470,7 +470,7 @@ agenda view showing the flagged items."
(insert "#+TAGS: " (mapconcat 'identity tags " ") "\n")
(insert "#+ALLPRIORITIES: " org-mobile-allpriorities "\n")
(when (file-exists-p (expand-file-name
org-mobile-directory "agendas.org"))
"agendas.org" org-mobile-directory))
(insert "* [[file:agendas.org][Agenda Views]]\n"))
(pcase-dolist (`(,_ . ,link-name) files-alist)
(insert (format "* [[file:%s][%s]]\n" link-name link-name)))
@ -627,11 +627,11 @@ The table of checksums is written to the file mobile-checksums."
(setq short (get-text-property (point) 'short-heading))
(when (and short (looking-at ".+"))
(replace-match short nil t)
(beginning-of-line 1))
(forward-line 0))
(when app
(end-of-line 1)
(insert app)
(beginning-of-line 1))
(forward-line 0))
(insert "* "))
((get-text-property (point) 'org-agenda-date-header)
(setq in-date t)
@ -649,7 +649,7 @@ The table of checksums is written to the file mobile-checksums."
(line-end-position))))
(delete-region (line-beginning-position) (line-end-position))
(insert line "<before>" prefix "</before>")
(beginning-of-line 1))
(forward-line 0))
(and (looking-at "[ \t]+") (replace-match "")))
(insert (if in-date "*** " "** "))
(end-of-line 1)
@ -666,7 +666,7 @@ The table of checksums is written to the file mobile-checksums."
(org-mobile-get-outline-path-link m))))
(insert " :PROPERTIES:\n :ORIGINAL_ID: " id
"\n :END:\n")))))
(beginning-of-line 2))
(forward-line 1))
(push (cons "agendas.org" (md5 (buffer-string)))
org-mobile-checksum-files))
(message "Agenda written to Org file %s" file)))
@ -1057,7 +1057,7 @@ be returned that indicates what went wrong."
(goto-char (match-beginning 4))
(insert new)
(delete-region (point) (+ (point) (length current)))
(org-align-tags))
(when org-auto-align-tags (org-align-tags)))
(t
(error
"Heading changed in the mobile device and on the computer")))))))
@ -1071,7 +1071,7 @@ be returned that indicates what went wrong."
(end-of-line 1)
(org-insert-heading-respect-content t)
(org-demote))
(beginning-of-line)
(forward-line 0)
(insert "* "))
(insert new))

41
lisp/org/org-mouse.el
View file

@ -185,8 +185,8 @@ Changing this variable requires a restart of Emacs to get activated."
(const :tag "Activate checkboxes" activate-checkboxes)))
(defun org-mouse-re-search-line (regexp)
"Search the current line for a given regular expression."
(beginning-of-line)
"Search the current line for a given regular expression REGEXP."
(forward-line 0)
(re-search-forward regexp (line-end-position) t))
(defun org-mouse-end-headline ()
@ -242,13 +242,13 @@ return `:middle'."
(defun org-mouse-empty-line ()
"Return non-nil if the line contains only white space."
(save-excursion (beginning-of-line) (looking-at "[ \t]*$")))
(save-excursion (forward-line 0) (looking-at "[ \t]*$")))
(defun org-mouse-next-heading ()
"Go to the next heading.
If there is none, ensure that the point is at the beginning of an empty line."
(unless (outline-next-heading)
(beginning-of-line)
(forward-line 0)
(unless (org-mouse-empty-line)
(end-of-line)
(newline))))
@ -261,7 +261,7 @@ insert the new heading before the current line. Otherwise, insert it
after the current heading."
(interactive)
(cl-case (org-mouse-line-position)
(:beginning (beginning-of-line)
(:beginning (forward-line 0)
(org-insert-heading))
(t (org-mouse-next-heading)
(org-insert-heading))))
@ -271,7 +271,7 @@ after the current heading."
For the acceptable UNITS, see `org-timestamp-change'."
(interactive)
(org-time-stamp nil)
(org-timestamp nil)
(when shift (org-timestamp-change shift units)))
(defun org-mouse-keyword-menu (keywords function &optional selected itemformat)
@ -426,13 +426,14 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(append
(let ((tags (org-get-tags nil t)))
(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags)) #'string-lessp)
(sort (mapcar #'car (org-get-buffer-tags))
(or org-tags-sort-function #'org-string<))
(lambda (tag)
(org-mouse-set-tags
(sort (if (member tag tags)
(delete tag tags)
(cons tag tags))
#'string-lessp)))
(or org-tags-sort-function #'org-string<))))
(lambda (tag) (member tag tags))
))
'("--"
@ -473,7 +474,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(sort (if (member ',name ',options)
(delete ',name ',options)
(cons ',name ',options))
'string-lessp)
#'org-string<)
" ")
nil nil nil 1)
(when (functionp ',function) (funcall ',function)))
@ -502,7 +503,8 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
["Check TODOs" org-show-todo-tree t]
("Check Tags"
,@(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags)) #'string-lessp)
(sort (mapcar #'car (org-get-buffer-tags))
(or org-tags-sort-function #'org-string<))
(lambda (tag) (org-tags-sparse-tree nil tag)))
"--"
["Custom Tag ..." org-tags-sparse-tree t])
@ -512,7 +514,8 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
["Display TODO List" org-todo-list t]
("Display Tags"
,@(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags)) #'string-lessp)
(sort (mapcar #'car (org-get-buffer-tags))
(or org-tags-sort-function #'org-string<))
(lambda (tag) (org-tags-view nil tag)))
"--"
["Custom Tag ..." org-tags-view t])
@ -566,7 +569,7 @@ This means, between the beginning of line and the point."
(defun org-mouse-insert-item (text)
(cl-case (org-mouse-line-position)
(:beginning ; insert before
(beginning-of-line)
(forward-line 0)
(looking-at "[ \t]*")
(open-line 1)
(indent-to-column (- (match-end 0) (match-beginning 0)))
@ -582,7 +585,7 @@ This means, between the beginning of line and the point."
(unless (looking-back org-mouse-punctuation (line-beginning-position))
(insert (concat org-mouse-punctuation " ")))))
(insert text)
(beginning-of-line))
(forward-line 0))
(advice-add 'dnd-insert-text :around #'org--mouse-dnd-insert-text)
(defun org--mouse-dnd-insert-text (orig-fun window action text &rest args)
@ -632,7 +635,7 @@ This means, between the beginning of line and the point."
(progn (save-excursion (goto-char (region-beginning)) (insert "[["))
(save-excursion (goto-char (region-end)) (insert "]]")))]
["Insert Link Here" (org-mouse-yank-link ',event)]))))
((save-excursion (beginning-of-line) (looking-at "[ \t]*#\\+STARTUP: \\(.*\\)"))
((save-excursion (forward-line 0) (looking-at "[ \t]*#\\+STARTUP: \\(.*\\)"))
(popup-menu
`(nil
,@(org-mouse-list-options-menu (mapcar #'car org-startup-options)
@ -713,7 +716,7 @@ This means, between the beginning of line and the point."
(popup-menu
'(nil
["Show Day" org-open-at-point t]
["Change Timestamp" org-time-stamp t]
["Change Timestamp" org-timestamp t]
["Delete Timestamp" (org-mouse-delete-timestamp) t]
["Compute Time Range" org-evaluate-time-range (org-at-date-range-p)]
"--"
@ -823,8 +826,8 @@ This means, between the beginning of line and the point."
:active (not (save-excursion
(org-mouse-re-search-line org-scheduled-regexp)))]
["Insert Timestamp"
(progn (org-mouse-end-headline) (insert " ") (org-time-stamp nil)) t]
; ["Timestamp (inactive)" org-time-stamp-inactive t]
(progn (org-mouse-end-headline) (insert " ") (org-timestamp nil)) t]
; ["Timestamp (inactive)" org-timestamp-inactive t]
"--"
["Archive Subtree" org-archive-subtree]
["Cut Subtree" org-cut-special]
@ -980,7 +983,7 @@ This means, between the beginning of line and the point."
(org-back-to-heading)
(let ((minlevel 1000)
(replace-text (concat (make-string (org-current-level) ?*) "* ")))
(beginning-of-line 2)
(forward-line 1)
(save-excursion
(while (not (or (eobp) (looking-at org-outline-regexp)))
(when (looking-at org-mouse-plain-list-regexp)
@ -1028,7 +1031,7 @@ This means, between the beginning of line and the point."
(unless (eq (marker-position marker) (marker-position endmarker))
(setq newhead (org-get-heading))))
(beginning-of-line 1)
(forward-line 1)
(save-excursion
(org-agenda-change-all-lines newhead hdmarker 'fixface))))
t))))

10
lisp/org/org-num.el
View file

@ -83,6 +83,7 @@
;;; Customization
;;;###autoload
(defcustom org-num-face nil
"Face to use for numbering.
When nil, use the same face as the headline. This value is
@ -104,6 +105,7 @@ Any `face' text property on the returned string overrides
:package-version '(Org . "9.3")
:type 'function)
;;;###autoload
(defcustom org-num-max-level nil
"Level below which headlines are not numbered.
When set to nil, all headlines are numbered."
@ -113,6 +115,7 @@ When set to nil, all headlines are numbered."
(integer :tag "Stop numbering at level"))
:safe (lambda (val) (or (null val) (wholenump val))))
;;;###autoload
(defcustom org-num-skip-commented nil
"Non-nil means commented sub-trees are not numbered."
:group 'org-appearance
@ -120,6 +123,7 @@ When set to nil, all headlines are numbered."
:type 'boolean
:safe #'booleanp)
;;;###autoload
(defcustom org-num-skip-footnotes nil
"Non-nil means footnotes sections are not numbered."
:group 'org-appearance
@ -127,6 +131,7 @@ When set to nil, all headlines are numbered."
:type 'boolean
:safe #'booleanp)
;;;###autoload
(defcustom org-num-skip-tags nil
"List of tags preventing the numbering of sub-trees.
@ -141,6 +146,7 @@ control tag inheritance."
:type '(repeat (string :tag "Tag"))
:safe (lambda (val) (and (listp val) (cl-every #'stringp val))))
;;;###autoload
(defcustom org-num-skip-unnumbered nil
"Non-nil means numbering obeys to UNNUMBERED property."
:group 'org-appearance
@ -214,7 +220,7 @@ Assume point is at a headline."
(let ((after-edit-functions
(list (lambda (o &rest _) (org-num--invalidate-overlay o))))
(o (save-excursion
(beginning-of-line)
(forward-line 0)
(skip-chars-forward "*")
(make-overlay (line-beginning-position) (1+ (point))))))
(overlay-put o 'org-num t)
@ -267,7 +273,7 @@ otherwise."
tags)
t)
(and org-num-skip-unnumbered
(org-entry-get (point) "UNNUMBERED")
(org-entry-get (point) "UNNUMBERED" 'selective)
t))))
(defun org-num--current-numbering (level skip)

61
lisp/org/org-pcomplete.el
View file

@ -22,6 +22,10 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library implementes completion support in Org mode buffers.
;;; Code:
;;;; Require other packages
@ -39,8 +43,9 @@
(declare-function org-before-first-heading-p "org" ())
(declare-function org-buffer-property-keys "org" (&optional specials defaults columns))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-property "org-element" property element)
(declare-function org-element-type "org-element" (element))
(declare-function org-element-property "org-element-ast" (property node &optional dflt force-undefer))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-end-of-meta-data "org" (&optional full))
(declare-function org-entry-properties "org" (&optional pom which))
(declare-function org-export-backend-options "ox" (cl-x) t)
@ -171,21 +176,29 @@ When completing for #+STARTUP, for example, this function returns
(defun org-parse-arguments ()
"Parse whitespace separated arguments in the current region."
(let ((begin (line-beginning-position))
(end (line-end-position))
begins args)
(save-restriction
(narrow-to-region begin end)
(if (equal (cons "searchhead" nil) (org-thing-at-point))
;; [[* foo<point> bar link::search option.
;; Arguments are not simply space-separated.
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward " \t\n[")
(setq begins (cons (point) begins))
(skip-chars-forward "^ \t\n[")
(setq args (cons (buffer-substring-no-properties
(car begins) (point))
args)))
(cons (reverse args) (reverse begins))))))
(let ((origin (point)))
(skip-chars-backward "^*" (line-beginning-position))
(cons (list (buffer-substring-no-properties (point) origin))
(list (point)))))
(let ((begin (line-beginning-position))
(end (line-end-position))
begins args)
(save-restriction
(narrow-to-region begin end)
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward " \t\n[")
(setq begins (cons (point) begins))
(skip-chars-forward "^ \t\n[")
(setq args (cons (buffer-substring-no-properties
(car begins) (point))
args)))
(cons (reverse args) (reverse begins)))))))
(defun org-pcomplete-initial ()
"Call the right completion function for first argument completions."
@ -306,7 +319,7 @@ When completing for #+STARTUP, for example, this function returns
"creator:" "date:" "d:" "email:" "*:" "e:" "::" "f:"
"inline:" "tex:" "p:" "pri:" "':" "-:" "stat:" "^:" "toc:"
"|:" "tags:" "tasks:" "<:" "todo:")
;; OPTION items from registered back-ends.
;; OPTION items from registered backends.
(let (items)
(dolist (backend (bound-and-true-p
org-export-registered-backends))
@ -361,14 +374,7 @@ This needs more work, to handle headings with lots of spaces in them."
;; Remove the leading asterisk from
;; `org-link-heading-search-string' result.
(push (substring (org-link-heading-search-string) 1) tbl))
(pcomplete-uniquify-list tbl)))
;; When completing a bracketed link, i.e., "[[*", argument
;; starts at the star, so remove this character.
;; Also, if the completion is done inside [[*head<point>]],
;; drop the closing parentheses.
(replace-regexp-in-string
"\\]+$" ""
(substring pcomplete-stub 1)))))
(pcomplete-uniquify-list tbl))))))
(defun pcomplete/org-mode/tag ()
"Complete a tag name. Omit tags already set."
@ -397,10 +403,9 @@ This needs more work, to handle headings with lots of spaces in them."
(goto-char (point-min))
(while (re-search-forward org-drawer-regexp nil t)
(let ((drawer (org-element-at-point)))
(when (memq (org-element-type drawer)
'(drawer property-drawer))
(when (org-element-type-p drawer '(drawer property-drawer))
(push (org-element-property :drawer-name drawer) names)
(goto-char (org-element-property :end drawer))))))
(goto-char (org-element-end drawer))))))
(pcomplete-uniquify-list names))))
(substring pcomplete-stub 1))) ;remove initial colon

Some files were not shown because too many files have changed in this diff Show more