diff options
Diffstat (limited to 'lisp')
97 files changed, 17541 insertions, 13921 deletions
diff --git a/lisp/org/ob-C.el b/lisp/org/ob-C.el index e08773bc977..ca587ccbbf5 100644 --- a/lisp/org/ob-C.el +++ b/lisp/org/ob-C.el @@ -34,11 +34,9 @@ (require 'cc-mode) (require 'ob) - +(require 'org-macs) (declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) -(declare-function org-remove-indentation "org" (code &optional n)) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("C++" . "cpp")) @@ -375,8 +373,8 @@ FORMAT can be either a format string or a function which is called with VAL." (pcase (org-babel-C-val-to-base-type v) (`stringp (setq type 'stringp)) (`floatp - (if (or (not type) (eq type 'integerp)) - (setq type 'floatp))) + (when (or (not type) (eq type 'integerp)) + (setq type 'floatp))) (`integerp (unless type (setq type 'integerp))))) val) @@ -395,9 +393,9 @@ of the same value." (setq val (string-to-char val)))) (let* ((type-data (org-babel-C-val-to-C-type val)) (type (car type-data)) - (formated (org-babel-C-format-val type-data val)) - (suffix (car formated)) - (data (cdr formated))) + (formatted (org-babel-C-format-val type-data val)) + (suffix (car formatted)) + (data (cdr formatted))) (format "%s %s%s = %s;" type var diff --git a/lisp/org/ob-J.el b/lisp/org/ob-J.el index 2d1715ac87a..b48562d2eab 100644 --- a/lisp/org/ob-J.el +++ b/lisp/org/ob-J.el @@ -31,8 +31,8 @@ ;;; Code: (require 'ob) +(require 'org-macs) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function j-console-ensure-session "ext:j-console" ()) (defcustom org-babel-J-command "jconsole" diff --git a/lisp/org/ob-calc.el b/lisp/org/ob-calc.el index 6ee93cd0445..d888f988f73 100644 --- a/lisp/org/ob-calc.el +++ b/lisp/org/ob-calc.el @@ -27,6 +27,7 @@ ;;; Code: (require 'ob) +(require 'org-macs) (require 'calc) (require 'calc-trail) (require 'calc-store) @@ -34,7 +35,6 @@ (declare-function calc-store-into "calc-store" (&optional var)) (declare-function calc-recall "calc-store" (&optional var)) (declare-function math-evaluate-expr "calc-ext" (x)) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-default-header-args:calc nil "Default arguments for evaluating a calc source block.") diff --git a/lisp/org/ob-clojure.el b/lisp/org/ob-clojure.el index 14c014a9f9a..0e5642adbbf 100644 --- a/lisp/org/ob-clojure.el +++ b/lisp/org/ob-clojure.el @@ -41,26 +41,30 @@ ;;; Code: (require 'cl-lib) (require 'ob) +(require 'org-macs) +(declare-function cider-jack-in "ext:cider" (&optional prompt-project cljs-too)) (declare-function cider-current-connection "ext:cider-client" (&optional type)) (declare-function cider-current-ns "ext:cider-client" ()) +(declare-function cider-repls "ext:cider-connection" (&optional type ensure)) (declare-function nrepl--merge "ext:nrepl-client" (dict1 dict2)) (declare-function nrepl-dict-get "ext:nrepl-client" (dict key)) (declare-function nrepl-dict-put "ext:nrepl-client" (dict key value)) -(declare-function nrepl-request:eval "ext:nrepl-client" - (input callback connection &optional session ns line column additional-params)) -(declare-function nrepl-sync-request:eval "ext:nrepl-client" - (input connection session &optional ns)) -(declare-function org-trim "org" (s &optional keep-lead)) +(declare-function nrepl-request:eval "ext:nrepl-client" (input callback connection &optional ns line column additional-params tooling)) +(declare-function nrepl-sync-request:eval "ext:nrepl-client" (input connection &optional ns tooling)) (declare-function slime-eval "ext:slime" (sexp &optional package)) (defvar nrepl-sync-request-timeout) +(defvar cider-buffer-ns) +(defvar sesman-system) +(defvar cider-version) (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("clojure" . "clj")) (defvar org-babel-default-header-args:clojure '()) -(defvar org-babel-header-args:clojure '((package . :any))) +(defvar org-babel-header-args:clojure '((ns . :any) + (package . :any))) (defcustom org-babel-clojure-sync-nrepl-timeout 10 "Timeout value, in seconds, of a Clojure sync call. @@ -80,19 +84,39 @@ If the value is nil, timeout is disabled." (const :tag "cider" cider) (const :tag "SLIME" slime))) +(defcustom org-babel-clojure-default-ns "user" + "Default Clojure namespace for source block when finding ns failed." + :type 'string + :group 'org-babel) + +(defun org-babel-clojure-cider-current-ns () + "Like `cider-current-ns' except `cider-find-ns'." + (or cider-buffer-ns + (let ((repl-buf (cider-current-connection))) + (and repl-buf (buffer-local-value 'cider-buffer-ns repl-buf))) + org-babel-clojure-default-ns)) + (defun org-babel-expand-body:clojure (body params) "Expand BODY according to PARAMS, return the expanded body." (let* ((vars (org-babel--get-vars params)) + (ns (or (cdr (assq :ns params)) + (org-babel-clojure-cider-current-ns))) (result-params (cdr (assq :result-params params))) - (print-level nil) (print-length nil) + (print-level nil) + (print-length nil) (body (org-trim - (if (null vars) (org-trim body) - (concat "(let [" - (mapconcat - (lambda (var) - (format "%S (quote %S)" (car var) (cdr var))) - vars "\n ") - "]\n" body ")"))))) + (concat + ;; Source block specified namespace :ns. + (and (cdr (assq :ns params)) (format "(ns %s)\n" ns)) + ;; Variables binding. + (if (null vars) (org-trim body) + (format "(let [%s]\n%s)" + (mapconcat + (lambda (var) + (format "%S (quote %S)" (car var) (cdr var))) + vars + "\n ") + body)))))) (if (or (member "code" result-params) (member "pp" result-params)) (format "(clojure.pprint/pprint (do %s))" body) @@ -102,9 +126,9 @@ If the value is nil, timeout is disabled." "Execute a block of Clojure code with Babel. The underlying process performed by the code block can be output using the :show-process parameter." - (let ((expanded (org-babel-expand-body:clojure body params)) - (response (list 'dict)) - result) + (let* ((expanded (org-babel-expand-body:clojure body params)) + (response (list 'dict)) + result) (cl-case org-babel-clojure-backend (cider (require 'cider) @@ -117,8 +141,7 @@ using the :show-process parameter." (let ((nrepl-sync-request-timeout org-babel-clojure-sync-nrepl-timeout)) (nrepl-sync-request:eval expanded - (cider-current-connection) - (cider-current-ns)))) + (cider-current-connection)))) (setq result (concat (nrepl-dict-get response @@ -152,8 +175,7 @@ using the :show-process parameter." (nrepl--merge response resp) ;; Update the status of the nREPL output session. (setq status (nrepl-dict-get response "status"))) - (cider-current-connection) - (cider-current-ns)) + (cider-current-connection)) ;; Wait until the nREPL code finished to be processed. (while (not (member "done" status)) @@ -193,6 +215,69 @@ using the :show-process parameter." (condition-case nil (org-babel-script-escape result) (error result))))) +(defun org-babel-clojure-initiate-session (&optional session _params) + "Initiate a session named SESSION according to PARAMS." + (when (and session (not (string= session "none"))) + (save-window-excursion + (cond + ((org-babel-comint-buffer-livep session) nil) + ;; CIDER jack-in to the Clojure project directory. + ((eq org-babel-clojure-backend 'cider) + (require 'cider) + (let ((session-buffer + (save-window-excursion + (if (version< cider-version "0.18.0") + ;; Older CIDER (without sesman) still need to use + ;; old way. + (cider-jack-in nil) ;jack-in without project + ;; New CIDER (with sesman to manage sessions). + (unless (cider-repls) + (let ((sesman-system 'CIDER)) + (call-interactively 'sesman-link-with-directory)))) + (current-buffer)))) + (when (org-babel-comint-buffer-livep session-buffer) + (sit-for .25) + session-buffer))) + ((eq org-babel-clojure-backend 'slime) + (error "Session evaluation with SLIME is not supported")) + (t + (error "Session initiate failed"))) + (get-buffer session)))) + +(defun org-babel-prep-session:clojure (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let ((session (org-babel-clojure-initiate-session session)) + (var-lines (org-babel-variable-assignments:clojure params))) + (when session + (org-babel-comint-in-buffer session + (dolist (var var-lines) + (insert var) + (comint-send-input nil t) + (org-babel-comint-wait-for-output session) + (sit-for .1) + (goto-char (point-max))))) + session)) + +(defun org-babel-clojure-var-to-clojure (var) + "Convert src block's VAR to Clojure variable." + (cond + ((listp var) + (replace-regexp-in-string "(" "'(" var)) + ((stringp var) + ;; Wrap Babel passed-in header argument value with quotes in Clojure. + (format "\"%s\"" var)) + (t + (format "%S" var)))) + +(defun org-babel-variable-assignments:clojure (params) + "Return a list of Clojure statements assigning the block's variables in PARAMS." + (mapcar + (lambda (pair) + (format "(def %s %s)" + (car pair) + (org-babel-clojure-var-to-clojure (cdr pair)))) + (org-babel--get-vars params))) + (provide 'ob-clojure) ;;; ob-clojure.el ends here diff --git a/lisp/org/ob-comint.el b/lisp/org/ob-comint.el index e27c1f8ed78..aa0d341da18 100644 --- a/lisp/org/ob-comint.el +++ b/lisp/org/ob-comint.el @@ -36,7 +36,7 @@ (defun org-babel-comint-buffer-livep (buffer) "Check if BUFFER is a comint buffer with a live process." - (let ((buffer (if buffer (get-buffer buffer)))) + (let ((buffer (when buffer (get-buffer buffer)))) (and buffer (buffer-live-p buffer) (get-buffer-process buffer) buffer))) (defmacro org-babel-comint-in-buffer (buffer &rest body) diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 9e78876787a..f877ff51bfd 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -35,6 +35,7 @@ (defvar org-babel-library-of-babel) (defvar org-edit-src-content-indentation) +(defvar org-link-file-path-type) (defvar org-src-lang-modes) (defvar org-src-preserve-indentation) @@ -47,10 +48,8 @@ (declare-function org-babel-ref-resolve "ob-ref" (ref)) (declare-function org-babel-ref-split-args "ob-ref" (arg-string)) (declare-function org-babel-tangle-comment-links "ob-tangle" (&optional info)) -(declare-function org-completing-read "org" (&rest args)) (declare-function org-current-level "org" ()) (declare-function org-cycle "org" (&optional arg)) -(declare-function org-do-remove-indentation "org" (&optional n)) (declare-function org-edit-src-code "org-src" (&optional code edit-buffer-name)) (declare-function org-edit-src-exit "org-src" ()) (declare-function org-element-at-point "org-element" ()) @@ -60,9 +59,7 @@ (declare-function org-element-type "org-element" (element)) (declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) (declare-function org-escape-code-in-region "org-src" (beg end)) -(declare-function org-get-indentation "org" (&optional line)) -(declare-function org-get-indentation "org" (&optional line)) -(declare-function org-in-regexp "org" (regexp &optional nlines visually)) +(declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) (declare-function org-indent-line "org" ()) (declare-function org-list-get-list-end "org-list" (item struct prevs)) (declare-function org-list-prevs-alist "org-list" (struct)) @@ -75,24 +72,18 @@ (declare-function org-narrow-to-subtree "org" ()) (declare-function org-next-block "org" (arg &optional backward block-regexp)) (declare-function org-open-at-point "org" (&optional in-emacs reference-buffer)) -(declare-function org-outline-overlay-data "org" (&optional use-markers)) (declare-function org-previous-block "org" (arg &optional block-regexp)) -(declare-function org-remove-indentation "org" (code &optional n)) -(declare-function org-reverse-string "org" (string)) -(declare-function org-set-outline-overlay-data "org" (data)) (declare-function org-show-context "org" (&optional key)) (declare-function org-src-coderef-format "org-src" (&optional element)) (declare-function org-src-coderef-regexp "org-src" (fmt &optional label)) +(declare-function org-src-get-lang-mode "org-src" (lang)) (declare-function org-table-align "org-table" ()) (declare-function org-table-end "org-table" (&optional table-type)) (declare-function org-table-import "org-table" (file arg)) (declare-function org-table-to-lisp "org-table" (&optional txt)) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function org-unescape-code-in-string "org-src" (s)) -(declare-function org-uniquify "org" (list)) (declare-function orgtbl-to-generic "org-table" (table params)) (declare-function orgtbl-to-orgtbl "org-table" (table params)) -(declare-function outline-show-all "outline" ()) (declare-function tramp-compat-make-temp-file "tramp-compat" (filename &optional dir-flag)) (defgroup org-babel nil @@ -186,9 +177,14 @@ This string must include a \"%s\" which will be replaced by the results." :safe #'booleanp) (defun org-babel-noweb-wrap (&optional regexp) - (concat org-babel-noweb-wrap-start - (or regexp "\\([^ \t\n].+?[^ \t]\\|[^ \t\n]\\)") - org-babel-noweb-wrap-end)) + "Return regexp matching a Noweb reference. + +Match any reference, or only those matching REGEXP, if non-nil. + +When matching, reference is stored in match group 1." + (concat (regexp-quote org-babel-noweb-wrap-start) + (or regexp "\\([^ \t\n]\\(?:.*?[^ \t\n]\\)?\\)") + (regexp-quote org-babel-noweb-wrap-end))) (defvar org-babel-src-name-regexp "^[ \t]*#\\+name:[ \t]*" @@ -416,7 +412,7 @@ then run `org-babel-switch-to-session'." (post . :any) (prologue . :any) (results . ((file list vector table scalar verbatim) - (raw html latex org code pp drawer) + (raw html latex org code pp drawer link graphics) (replace silent none append prepend) (output value))) (rownames . ((no yes))) @@ -532,7 +528,7 @@ to raise errors for all languages.") "Hook for functions to be called after `org-babel-execute-src-block'") (defun org-babel-named-src-block-regexp-for-name (&optional name) - "Generate a regexp used to match a src block named NAME. + "Generate a regexp used to match a source block named NAME. If NAME is nil, match any name. Matched name is then put in match group 9. Other match groups are defined in `org-babel-src-block-regexp'." @@ -566,7 +562,7 @@ Remove final newline character and spurious indentation." ;;; functions (defvar org-babel-current-src-block-location nil - "Marker pointing to the src block currently being executed. + "Marker pointing to the source block currently being executed. This may also point to a call line or an inline code block. If multiple blocks are being executed (e.g., in chained execution through use of the :var header argument) this marker points to @@ -577,9 +573,10 @@ the outer-most code block.") (defun org-babel-get-src-block-info (&optional light datum) "Extract information from a source block or inline source block. -Optional argument LIGHT does not resolve remote variable -references; a process which could likely result in the execution -of other code blocks. +When optional argument LIGHT is non-nil, Babel does not resolve +remote variable references; a process which could likely result +in the execution of other code blocks, and do not evaluate Lisp +values in parameters. By default, consider the block at point. However, when optional argument DATUM is provided, extract information from that parsed @@ -610,8 +607,9 @@ a list with the following pattern: ;; properties applicable to its location within ;; the document. (org-with-point-at (org-element-property :begin datum) - (org-babel-params-from-properties lang)) - (mapcar #'org-babel-parse-header-arguments + (org-babel-params-from-properties lang light)) + (mapcar (lambda (h) + (org-babel-parse-header-arguments h light)) (cons (org-element-property :parameters datum) (org-element-property :header datum))))) (or (org-element-property :switches datum) "") @@ -654,7 +652,7 @@ block." (let* ((params (nth 2 info)) (cache (let ((c (cdr (assq :cache params)))) (and (not arg) c (string= "yes" c)))) - (new-hash (and cache (org-babel-sha1-hash info))) + (new-hash (and cache (org-babel-sha1-hash info :eval))) (old-hash (and cache (org-babel-current-result-hash))) (current-cache (and new-hash (equal new-hash old-hash)))) (cond @@ -681,9 +679,16 @@ block." (replace-regexp-in-string (org-src-coderef-regexp coderef) "" expand nil nil 1)))) (dir (cdr (assq :dir params))) + (mkdirp (cdr (assq :mkdirp params))) (default-directory - (or (and dir (file-name-as-directory (expand-file-name dir))) - default-directory)) + (cond + ((not dir) default-directory) + ((member mkdirp '("no" "nil" nil)) + (file-name-as-directory (expand-file-name dir))) + (t + (let ((d (file-name-as-directory (expand-file-name dir)))) + (make-directory d 'parents) + d)))) (cmd (intern (concat "org-babel-execute:" lang))) result) (unless (fboundp cmd) @@ -703,13 +708,20 @@ block." (not (listp r))) (list (list r)) r))) - (let ((file (cdr (assq :file params)))) + (let ((file (and (member "file" result-params) + (cdr (assq :file params))))) ;; If non-empty result and :file then write to :file. (when file - (when result + ;; If `:results' are special types like `link' or + ;; `graphics', don't write result to `:file'. Only + ;; insert a link to `:file'. + (when (and result + (not (or (member "link" result-params) + (member "graphics" result-params)))) (with-temp-file file (insert (org-babel-format-result - result (cdr (assq :sep params)))))) + result + (cdr (assq :sep params)))))) (setq result file)) ;; Possibly perform post process provided its ;; appropriate. Dynamically bind "*this*" to the @@ -1013,7 +1025,7 @@ evaluation mechanisms." (call-interactively (key-binding (or key (read-key-sequence nil)))))) -(defvar org-bracket-link-regexp) +(defvar org-link-bracket-re) (defun org-babel-active-location-p () (memq (org-element-type (save-match-data (org-element-context))) @@ -1021,30 +1033,32 @@ evaluation mechanisms." ;;;###autoload (defun org-babel-open-src-block-result (&optional re-run) - "If `point' is on a src block then open the results of the -source code block, otherwise return nil. With optional prefix -argument RE-RUN the source-code block is evaluated even if -results already exist." + "Open results of source block at point. + +If `point' is on a source block then open the results of the source +code block, otherwise return nil. With optional prefix argument +RE-RUN the source-code block is evaluated even if results already +exist." (interactive "P") - (let ((info (org-babel-get-src-block-info 'light))) - (when info - (save-excursion - ;; go to the results, if there aren't any then run the block - (goto-char (or (and (not re-run) (org-babel-where-is-src-block-result)) - (progn (org-babel-execute-src-block) - (org-babel-where-is-src-block-result)))) - (end-of-line 1) - (while (looking-at "[\n\r\t\f ]") (forward-char 1)) - ;; open the results - (if (looking-at org-bracket-link-regexp) - ;; file results - (org-open-at-point) - (let ((r (org-babel-format-result - (org-babel-read-result) (cdr (assq :sep (nth 2 info)))))) - (pop-to-buffer (get-buffer-create "*Org-Babel Results*")) - (delete-region (point-min) (point-max)) - (insert r))) - t)))) + (pcase (org-babel-get-src-block-info 'light) + (`(,_ ,_ ,arguments ,_ ,_ ,start ,_) + (save-excursion + ;; Go to the results, if there aren't any then run the block. + (goto-char start) + (goto-char (or (and (not re-run) (org-babel-where-is-src-block-result)) + (progn (org-babel-execute-src-block) + (org-babel-where-is-src-block-result)))) + (end-of-line) + (skip-chars-forward " \r\t\n") + ;; Open the results. + (if (looking-at org-link-bracket-re) (org-open-at-point) + (let ((r (org-babel-format-result (org-babel-read-result) + (cdr (assq :sep arguments))))) + (pop-to-buffer (get-buffer-create "*Org Babel Results*")) + (erase-buffer) + (insert r))) + t)) + (_ nil))) ;;;###autoload (defmacro org-babel-map-src-blocks (file &rest body) @@ -1224,11 +1238,14 @@ the current subtree." (widen)))) ;;;###autoload -(defun org-babel-sha1-hash (&optional info) - "Generate an sha1 hash based on the value of info." +(defun org-babel-sha1-hash (&optional info context) + "Generate a sha1 hash based on the value of INFO. +CONTEXT specifies the context of evaluation. It can be `:eval', +`:export', `:tangle'. A nil value means `:eval'." (interactive) (let ((print-level nil) - (info (or info (org-babel-get-src-block-info)))) + (info (or info (org-babel-get-src-block-info))) + (context (or context :eval))) (setf (nth 2 info) (sort (copy-sequence (nth 2 info)) (lambda (a b) (string< (car a) (car b))))) @@ -1256,8 +1273,9 @@ the current subtree." ;; expanded body (lang (nth 0 info)) (params (nth 2 info)) - (body (if (org-babel-noweb-p params :eval) - (org-babel-expand-noweb-references info) (nth 1 info))) + (body (if (org-babel-noweb-p params context) + (org-babel-expand-noweb-references info) + (nth 1 info))) (expand-cmd (intern (concat "org-babel-expand-body:" lang))) (assignments-cmd (intern (concat "org-babel-variable-assignments:" lang))) @@ -1288,19 +1306,6 @@ the current subtree." (looking-at org-babel-result-regexp) (match-string-no-properties 1))))) -(defun org-babel-set-current-result-hash (hash info) - "Set the current in-buffer hash to HASH." - (org-with-wide-buffer - (goto-char (org-babel-where-is-src-block-result nil info)) - (looking-at org-babel-result-regexp) - (goto-char (match-beginning 1)) - (mapc #'delete-overlay (overlays-at (point))) - (forward-char org-babel-hash-show) - (mapc #'delete-overlay (overlays-at (point))) - (replace-match hash nil nil nil 1) - (beginning-of-line) - (org-babel-hide-hash))) - (defun org-babel-hide-hash () "Hide the hash in the current results line. Only the initial `org-babel-hash-show' characters of the hash @@ -1426,24 +1431,27 @@ portions of results lines." (lambda () (add-hook 'change-major-mode-hook 'org-babel-show-result-all 'append 'local))) -(defvar org-file-properties) -(defun org-babel-params-from-properties (&optional lang) - "Retrieve parameters specified as properties. -Return a list of association lists of source block params +(defun org-babel-params-from-properties (&optional lang no-eval) + "Retrieve source block parameters specified as properties. + +LANG is the language of the source block, as a string. When +optional argument NO-EVAL is non-nil, do not evaluate Lisp values +in parameters. + +Return a list of association lists of source block parameters specified in the properties of the current outline entry." (save-match-data (list - ;; header arguments specified with the header-args property at + ;; Header arguments specified with the header-args property at ;; point of call. (org-babel-parse-header-arguments - (org-entry-get org-babel-current-src-block-location - "header-args" - 'inherit)) - (and lang ; language-specific header arguments at point of call + (org-entry-get (point) "header-args" 'inherit) + no-eval) + ;; Language-specific header arguments at point of call. + (and lang (org-babel-parse-header-arguments - (org-entry-get org-babel-current-src-block-location - (concat "header-args:" lang) - 'inherit)))))) + (org-entry-get (point) (concat "header-args:" lang) 'inherit) + no-eval))))) (defun org-babel-balanced-split (string alts) "Split STRING on instances of ALTS. @@ -1531,9 +1539,11 @@ balanced instances of \"[ \t]:\", set ALTS to ((32 9) . 58)." (cons el acc)))) list :initial-value nil)))) -(defun org-babel-parse-header-arguments (arg-string) - "Parse a string of header arguments returning an alist." - (when (> (length arg-string) 0) +(defun org-babel-parse-header-arguments (string &optional no-eval) + "Parse header arguments in STRING. +When optional argument NO-EVAL is non-nil, do not evaluate Lisp +in parameters. Return an alist." + (when (org-string-nw-p string) (org-babel-parse-multiple-vars (delq nil (mapcar @@ -1542,10 +1552,12 @@ balanced instances of \"[ \t]:\", set ALTS to ((32 9) . 58)." "\\([^ \f\t\n\r\v]+\\)[ \f\t\n\r\v]+\\([^ \f\t\n\r\v]+.*\\)" arg) (cons (intern (match-string 1 arg)) - (org-babel-read (org-babel-chomp (match-string 2 arg)))) + (org-babel-read (org-babel-chomp (match-string 2 arg)) + no-eval)) (cons (intern (org-babel-chomp arg)) nil))) - (let ((raw (org-babel-balanced-split arg-string '((32 9) . 58)))) - (cons (car raw) (mapcar (lambda (r) (concat ":" r)) (cdr raw))))))))) + (let ((raw (org-babel-balanced-split string '((32 9) . 58)))) + (cons (car raw) + (mapcar (lambda (r) (concat ":" r)) (cdr raw))))))))) (defun org-babel-parse-multiple-vars (header-arguments) "Expand multiple variable assignments behind a single :var keyword. @@ -1845,7 +1857,7 @@ With optional prefix argument ARG, jump backward ARG many source blocks." ;;;###autoload (defun org-babel-mark-block () - "Mark current src block." + "Mark current source block." (interactive) (let ((head (org-babel-where-is-src-block-head))) (when head @@ -1876,7 +1888,7 @@ region is not active then the point is demarcated." (save-excursion (goto-char place) (let ((lang (nth 0 info)) - (indent (make-string (org-get-indentation) ?\s))) + (indent (make-string (current-indentation) ?\s))) (when (string-match "^[[:space:]]*$" (buffer-substring (point-at-bol) (point-at-eol))) @@ -2083,7 +2095,7 @@ Return nil if ELEMENT cannot be read." (`paragraph ;; Treat paragraphs containing a single link specially. (skip-chars-forward " \t") - (if (and (looking-at org-bracket-link-regexp) + (if (and (looking-at org-link-bracket-re) (save-excursion (goto-char (match-end 0)) (skip-chars-forward " \r\t\n") @@ -2125,7 +2137,7 @@ Return nil if ELEMENT cannot be read." If the path of the link is a file path it is expanded using `expand-file-name'." (let* ((case-fold-search t) - (raw (and (looking-at org-bracket-link-regexp) + (raw (and (looking-at org-link-bracket-re) (org-no-properties (match-string 1)))) (type (and (string-match org-link-types-re raw) (match-string 1 raw)))) @@ -2206,10 +2218,10 @@ code ---- the results are extracted in the syntax of the source optional LANG argument. list ---- the results are rendered as a list. This option not - allowed for inline src blocks. + allowed for inline source blocks. table --- the results are rendered as a table. This option not - allowed for inline src blocks. + allowed for inline source blocks. INFO may provide the values of these header arguments (in the `header-arguments-alist' see the docstring for @@ -2273,7 +2285,7 @@ INFO may provide the values of these header arguments (in the (goto-char (org-element-property :end inline)) (skip-chars-backward " \t")) (unless inline - (setq indent (org-get-indentation)) + (setq indent (current-indentation)) (forward-line 1)) (setq beg (point)) (cond @@ -2297,7 +2309,7 @@ INFO may provide the values of these header arguments (in the (setq start inline-start) (setq finish inline-finish) (setq no-newlines t)) - (let ((before-finish (marker-position end))) + (let ((before-finish (copy-marker end))) (goto-char end) (insert (concat finish (unless no-newlines "\n"))) (goto-char beg) @@ -2362,24 +2374,24 @@ INFO may provide the values of these header arguments (in the ;; possibly wrap result (cond ((assq :wrap (nth 2 info)) - (let ((name (or (cdr (assq :wrap (nth 2 info))) "RESULTS"))) - (funcall wrap (concat "#+BEGIN_" name) - (concat "#+END_" (car (split-string name))) + (let ((name (or (cdr (assq :wrap (nth 2 info))) "results"))) + (funcall wrap (concat "#+begin_" name) + (concat "#+end_" (car (split-string name))) nil nil (concat "{{{results(@@" name ":") "@@)}}}"))) ((member "html" result-params) - (funcall wrap "#+BEGIN_EXPORT html" "#+END_EXPORT" nil nil + (funcall wrap "#+begin_export html" "#+end_export" nil nil "{{{results(@@html:" "@@)}}}")) ((member "latex" result-params) - (funcall wrap "#+BEGIN_EXPORT latex" "#+END_EXPORT" nil nil + (funcall wrap "#+begin_export latex" "#+end_export" nil nil "{{{results(@@latex:" "@@)}}}")) ((member "org" result-params) (goto-char beg) (when (org-at-table-p) (org-cycle)) - (funcall wrap "#+BEGIN_SRC org" "#+END_SRC" nil nil + (funcall wrap "#+begin_src org" "#+end_src" nil nil "{{{results(src_org{" "})}}}")) ((member "code" result-params) (let ((lang (or lang "none"))) - (funcall wrap (format "#+BEGIN_SRC %s%s" lang results-switches) - "#+END_SRC" nil nil + (funcall wrap (format "#+begin_src %s%s" lang results-switches) + "#+end_src" nil nil (format "{{{results(src_%s[%s]{" lang results-switches) "})}}}"))) ((member "raw" result-params) @@ -2388,7 +2400,7 @@ INFO may provide the values of these header arguments (in the ;; Stay backward compatible with <7.9.2 (member "wrap" result-params)) (goto-char beg) (when (org-at-table-p) (org-cycle)) - (funcall wrap ":RESULTS:" ":END:" 'no-escape nil + (funcall wrap ":results:" ":end:" 'no-escape nil "{{{results(" ")}}}")) ((and inline (member "file" result-params)) (funcall wrap nil nil nil nil "{{{results(" ")}}}")) @@ -2469,7 +2481,7 @@ in the buffer." (defun org-babel-result-end () "Return the point at the end of the current set of results." (cond ((looking-at-p "^[ \t]*$") (point)) ;no result - ((looking-at-p (format "^[ \t]*%s[ \t]*$" org-bracket-link-regexp)) + ((looking-at-p (format "^[ \t]*%s[ \t]*$" org-link-bracket-re)) (line-beginning-position 2)) (t (let ((element (org-element-at-point))) @@ -2489,15 +2501,20 @@ in the buffer." If the `default-directory' is different from the containing file's directory then expand relative links." (when (stringp result) - (format "[[file:%s]%s]" - (if (and default-directory - buffer-file-name - (not (string= (expand-file-name default-directory) - (expand-file-name - (file-name-directory buffer-file-name))))) - (expand-file-name result default-directory) - result) - (if description (concat "[" description "]") "")))) + (let ((same-directory? + (and buffer-file-name + (not (string= (expand-file-name default-directory) + (expand-file-name + (file-name-directory buffer-file-name))))))) + (format "[[file:%s]%s]" + (if (and default-directory buffer-file-name same-directory?) + (if (eq org-link-file-path-type 'adaptive) + (file-relative-name + (expand-file-name result default-directory) + (file-name-directory (buffer-file-name))) + (expand-file-name result default-directory)) + result) + (if description (concat "[" description "]") ""))))) (defun org-babel-examplify-region (beg end &optional results-switches inline) "Comment out region using the inline `==' or `: ' org example quote." @@ -2535,7 +2552,7 @@ file's directory then expand relative links." (unless (eq (org-element-type element) 'src-block) (error "Not in a source block")) (goto-char (org-babel-where-is-src-block-head element)) - (let* ((ind (org-get-indentation)) + (let* ((ind (current-indentation)) (body-start (line-beginning-position 2)) (body (org-element-normalize-string (if (or org-src-preserve-indentation @@ -2621,19 +2638,6 @@ parameters when merging lists." results (split-string (if (stringp value) value (eval value t)))))) - (`(,(or :file :file-ext) . ,value) - ;; `:file' and `:file-ext' are regular keywords but they - ;; imply a "file" `:results' and a "results" `:exports'. - (when value - (setq results - (funcall merge results-exclusive-groups results '("file"))) - (unless (or (member "both" exports) - (member "none" exports) - (member "code" exports)) - (setq exports - (funcall merge - exports-exclusive-groups exports '("results")))) - (push pair params))) (`(:exports . ,value) (setq exports (funcall merge exports-exclusive-groups @@ -2662,12 +2666,6 @@ parameters when merging lists." ;; Return merged params. params)) -(defvar org-babel-use-quick-and-dirty-noweb-expansion nil - "Set to true to use regular expressions to expand noweb references. -This results in much faster noweb reference expansion but does -not properly allow code blocks to inherit the \":noweb-ref\" -header argument from buffer or subtree wide properties.") - (defun org-babel-noweb-p (params context) "Check if PARAMS require expansion in CONTEXT. CONTEXT may be one of :tangle, :export or :eval." @@ -2714,16 +2712,8 @@ block but are passed literally to the \"example-block\"." (body (nth 1 info)) (ob-nww-start org-babel-noweb-wrap-start) (ob-nww-end org-babel-noweb-wrap-end) - (comment (string= "noweb" (cdr (assq :comments (nth 2 info))))) - (rx-prefix (concat "\\(" org-babel-src-name-regexp "\\|" - ":noweb-ref[ \t]+" "\\)")) (new-body "") (nb-add (lambda (text) (setq new-body (concat new-body text)))) - (c-wrap (lambda (text) - (with-temp-buffer - (funcall (intern (concat lang "-mode"))) - (comment-region (point) (progn (insert text) (point))) - (org-trim (buffer-string))))) index source-name evaluate prefix) (with-temp-buffer (setq-local org-babel-noweb-wrap-start ob-nww-start) @@ -2755,63 +2745,77 @@ block but are passed literally to the \"example-block\"." (let ((raw (org-babel-ref-resolve source-name))) (if (stringp raw) raw (format "%S" raw))) (or - ;; Retrieve from the library of babel. - (nth 2 (assoc (intern source-name) - org-babel-library-of-babel)) + ;; Retrieve from the Library of Babel. + (nth 2 (assoc-string source-name org-babel-library-of-babel)) ;; Return the contents of headlines literally. (save-excursion (when (org-babel-ref-goto-headline-id source-name) - (org-babel-ref-headline-body))) + (org-babel-ref-headline-body))) ;; Find the expansion of reference in this buffer. - (let ((rx (concat rx-prefix source-name "[ \t\n]")) - expansion) - (save-excursion - (goto-char (point-min)) - (if org-babel-use-quick-and-dirty-noweb-expansion - (while (re-search-forward rx nil t) - (let* ((i (org-babel-get-src-block-info 'light)) - (body (if (org-babel-noweb-p (nth 2 i) :eval) - (org-babel-expand-noweb-references i) - (nth 1 i))) - (sep (or (cdr (assq :noweb-sep (nth 2 i))) - "\n")) - (full (if comment - (let ((cs (org-babel-tangle-comment-links i))) - (concat (funcall c-wrap (car cs)) "\n" - body "\n" - (funcall c-wrap (cadr cs)))) - body))) - (setq expansion (cons sep (cons full expansion))))) - (org-babel-map-src-blocks nil - (let ((i (let ((org-babel-current-src-block-location (point))) - (org-babel-get-src-block-info 'light)))) - (when (equal (or (cdr (assq :noweb-ref (nth 2 i))) - (nth 4 i)) - source-name) - (let* ((body (if (org-babel-noweb-p (nth 2 i) :eval) - (org-babel-expand-noweb-references i) - (nth 1 i))) - (sep (or (cdr (assq :noweb-sep (nth 2 i))) - "\n")) - (full (if comment - (let ((cs (org-babel-tangle-comment-links i))) - (concat (funcall c-wrap (car cs)) "\n" - body "\n" - (funcall c-wrap (cadr cs)))) - body))) - (setq expansion - (cons sep (cons full expansion))))))))) - (and expansion - (mapconcat #'identity (nreverse (cdr expansion)) ""))) + (save-excursion + (goto-char (point-min)) + (let* ((name-regexp + (org-babel-named-src-block-regexp-for-name + source-name)) + (comment + (string= "noweb" + (cdr (assq :comments (nth 2 info))))) + (c-wrap + (lambda (s) + ;; Comment, according to LANG mode, + ;; string S. Return new string. + (with-temp-buffer + (funcall (org-src-get-lang-mode lang)) + (comment-region (point) + (progn (insert s) (point))) + (org-trim (buffer-string))))) + (expand-body + (lambda (i) + ;; Expand body of code blocked + ;; represented by block info I. + (let ((b (if (org-babel-noweb-p (nth 2 i) :eval) + (org-babel-expand-noweb-references i) + (nth 1 i)))) + (if (not comment) b + (let ((cs (org-babel-tangle-comment-links i))) + (concat (funcall c-wrap (car cs)) "\n" + b "\n" + (funcall c-wrap (cadr cs))))))))) + (if (and (re-search-forward name-regexp nil t) + (not (org-in-commented-heading-p))) + ;; Found a source block named SOURCE-NAME. + ;; Assume it is unique; do not look after + ;; `:noweb-ref' header argument. + (funcall expand-body + (org-babel-get-src-block-info 'light)) + ;; Though luck. We go into the long process + ;; of checking each source block and expand + ;; those with a matching Noweb reference. + (let ((expansion nil)) + (org-babel-map-src-blocks nil + (unless (org-in-commented-heading-p) + (let* ((info + (org-babel-get-src-block-info 'light)) + (parameters (nth 2 info))) + (when (equal source-name + (cdr (assq :noweb-ref parameters))) + (push (funcall expand-body info) expansion) + (push (or (cdr (assq :noweb-sep parameters)) + "\n") + expansion))))) + (when expansion + (mapconcat #'identity + (nreverse (cdr expansion)) + "")))))) ;; Possibly raise an error if named block doesn't exist. (if (or org-babel-noweb-error-all-langs (member lang org-babel-noweb-error-langs)) - (error "%s" (concat - (org-babel-noweb-wrap source-name) - "could not be resolved (see " - "`org-babel-noweb-error-langs')")) + (error "%s could not be resolved (see \ +`org-babel-noweb-error-langs')" + (org-babel-noweb-wrap source-name)) ""))) - "[\n\r]") (concat "\n" prefix)))))) + "[\n\r]") + (concat "\n" prefix)))))) (funcall nb-add (buffer-substring index (point-max)))) new-body)) @@ -2927,30 +2931,30 @@ situations in which is it not appropriate." (defun org-babel--string-to-number (string) "If STRING represents a number return its value. Otherwise return nil." - (and (string-match-p "\\`-?[0-9]*\\.?[0-9]*\\'" string) + (and (string-match-p "\\`-?\\([0-9]\\|\\([1-9]\\|[0-9]*\\.\\)[0-9]*\\)\\'" string) (string-to-number string))) (defun org-babel-import-elisp-from-file (file-name &optional separator) "Read the results located at FILE-NAME into an elisp table. If the table is trivial, then return it as a scalar." - (let (result) - (save-window-excursion - (with-temp-buffer - (condition-case err - (progn - (org-table-import file-name separator) - (delete-file file-name) - (setq result (mapcar (lambda (row) - (mapcar #'org-babel-string-read row)) - (org-table-to-lisp)))) - (error (message "Error reading results: %s" err) nil))) - (if (null (cdr result)) ;; if result is trivial vector, then scalarize it - (if (consp (car result)) - (if (null (cdr (car result))) - (caar result) - result) - (car result)) - result)))) + (save-window-excursion + (let ((result + (with-temp-buffer + (condition-case err + (progn + (org-table-import file-name separator) + (delete-file file-name) + (delq nil + (mapcar (lambda (row) + (and (not (eq row 'hline)) + (mapcar #'org-babel-string-read row))) + (org-table-to-lisp)))) + (error (message "Error reading results: %s" err) nil))))) + (pcase result + (`((,scalar)) scalar) + (`((,_ ,_ . ,_)) result) + (`(,scalar) scalar) + (_ result))))) (defun org-babel-string-read (cell) "Strip nested \"s from around strings." @@ -3136,7 +3140,8 @@ after the babel API for OLD-type source blocks is fully defined. Callers of this function will probably want to add an entry to `org-src-lang-modes' as well." (dolist (fn '("execute" "expand-body" "prep-session" - "variable-assignments" "load-session")) + "variable-assignments" "load-session" + "edit-prep")) (let ((sym (intern-soft (concat "org-babel-" fn ":" old)))) (when (and sym (fboundp sym)) (defalias (intern (concat "org-babel-" fn ":" new)) sym)))) @@ -3147,10 +3152,6 @@ Callers of this function will probably want to add an entry to (when (and sym (boundp sym)) (defvaralias (intern (concat "org-babel-" var ":" new)) sym))))) -(defun org-babel-strip-quotes (string) - "Strip \\\"s from around a string, if applicable." - (org-unbracket-string "\"" "\"" string)) - (provide 'ob-core) ;; Local variables: diff --git a/lisp/org/ob-dot.el b/lisp/org/ob-dot.el index 35bc8939518..73a16738a0b 100644 --- a/lisp/org/ob-dot.el +++ b/lisp/org/ob-dot.el @@ -69,6 +69,8 @@ This function is called by `org-babel-execute-src-block'." (cmdline (or (cdr (assq :cmdline params)) (format "-T%s" (file-name-extension out-file)))) (cmd (or (cdr (assq :cmd params)) "dot")) + (coding-system-for-read 'utf-8) ;use utf-8 with sub-processes + (coding-system-for-write 'utf-8) (in-file (org-babel-temp-file "dot-"))) (with-temp-file in-file (insert (org-babel-expand-body:dot body params))) diff --git a/lisp/org/ob-emacs-lisp.el b/lisp/org/ob-emacs-lisp.el index c9f6c49ed98..18b0d4841e8 100644 --- a/lisp/org/ob-emacs-lisp.el +++ b/lisp/org/ob-emacs-lisp.el @@ -26,7 +26,13 @@ ;; Org-Babel support for evaluating emacs-lisp code ;;; Code: -(require 'ob) + +(require 'ob-core) + +(declare-function org-babel--get-vars "ob" (params)) +(declare-function org-babel-result-cond "ob" (result-params scalar-form &rest table-forms)) +(declare-function org-babel-reassemble-table "ob" (table colnames rownames)) +(declare-function org-babel-pick-name "ob" (names selector)) (defconst org-babel-header-args:emacs-lisp '((lexical . :any)) "Emacs-lisp specific header arguments.") @@ -34,10 +40,11 @@ (defvar org-babel-default-header-args:emacs-lisp '((:lexical . "no")) "Default arguments for evaluating an emacs-lisp source block. -A value of \"yes\" or t causes src blocks to be eval'd using +A value of \"yes\" or t causes source blocks to be eval'd using lexical scoping. It can also be an alist mapping symbols to -their value. It is used as the optional LEXICAL argument to -`eval', which see.") +their value. It is used both as the optional LEXICAL argument to +`eval', and as the value for `lexical-binding' in buffers created +by `org-edit-src-code'.") (defun org-babel-expand-body:emacs-lisp (body params) "Expand BODY according to PARAMS, return the expanded body." @@ -65,9 +72,7 @@ their value. It is used as the optional LEXICAL argument to (member "pp" result-params)) (concat "(pp " body ")") body)) - (if (listp lexical) - lexical - (member lexical '("yes" "t")))))) + (org-babel-emacs-lisp-lexical lexical)))) (org-babel-result-cond result-params (let ((print-level nil) (print-length nil)) @@ -82,6 +87,23 @@ their value. It is used as the optional LEXICAL argument to (org-babel-pick-name (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))) +(defun org-babel-emacs-lisp-lexical (lexical) + "Interpret :lexical source block argument. +Convert LEXICAL into the form appropriate for `lexical-binding' +and the LEXICAL argument to `eval'." + (if (listp lexical) + lexical + (not (null (member lexical '("yes" "t")))))) + +(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." + (setq lexical-binding + (org-babel-emacs-lisp-lexical + (org-babel-read + (cdr (assq :lexical (nth 2 info))))))) + (org-babel-make-language-alias "elisp" "emacs-lisp") (provide 'ob-emacs-lisp) diff --git a/lisp/org/ob-eshell.el b/lisp/org/ob-eshell.el new file mode 100644 index 00000000000..800abce2f8b --- /dev/null +++ b/lisp/org/ob-eshell.el @@ -0,0 +1,102 @@ +;;; ob-eshell.el --- Babel Functions for Eshell -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: stardiviner <numbchild@gmail.com> +;; Keywords: literate programming, reproducible research +;; Homepage: https://orgmode.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org Babel support for evaluating Eshell source code. + +;;; Code: +(require 'ob) +(require 'eshell) + +(defvar org-babel-default-header-args:eshell '()) + +(defun org-babel-execute:eshell (body params) + "Execute a block of Eshell code BODY with PARAMS. +This function is called by `org-babel-execute-src-block'. + +The BODY can be any code which allowed executed in Eshell. +Eshell allow to execute normal shell command and Elisp code. +More details please reference Eshell Info. + +The PARAMS are variables assignments." + (let* ((session (org-babel-eshell-initiate-session + (cdr (assq :session params)))) + (full-body (org-babel-expand-body:generic + body params (org-babel-variable-assignments:eshell params)))) + (if session + (progn + (with-current-buffer session + (dolist (line (split-string full-body "\n")) + (goto-char eshell-last-output-end) + (insert line) + (eshell-send-input)) + ;; get output of last input + ;; TODO: collect all output instead of last command's output. + (goto-char eshell-last-input-end) + (buffer-substring-no-properties (point) eshell-last-output-start))) + (with-temp-buffer + (eshell-command full-body t) + (buffer-string))))) + +(defun org-babel-prep-session:eshell (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (org-babel-eshell-initiate-session session)) + ;; Eshell session buffer is read from variable `eshell-buffer-name'. + (eshell-buffer-name session) + (var-lines (org-babel-variable-assignments:eshell params))) + (call-interactively #'eshell) + (mapc #'eshell-command var-lines) + session)) + +(defun ob-eshell-session-live-p (session) + "Non-nil if Eshell SESSION exists." + (get-buffer session)) + +(defun org-babel-eshell-initiate-session (&optional session _params) + "Initiate a session named SESSION." + (when (and session (not (string= session "none"))) + (save-window-excursion + (unless (ob-eshell-session-live-p session) + (let ((eshell-buffer-name session)) (eshell)))) + session)) + +(defun org-babel-variable-assignments:eshell (params) + "Convert ob-eshell :var specified variables into Eshell variables assignments." + (mapcar + (lambda (pair) + (format "(setq %s %S)" (car pair) (cdr pair))) + (org-babel--get-vars params))) + +(defun org-babel-load-session:eshell (session body params) + "Load BODY into SESSION with PARAMS." + (save-window-excursion + (let ((buffer (org-babel-prep-session:eshell session params))) + (with-current-buffer buffer + (goto-char (point-max)) + (insert (org-babel-chomp body))) + buffer))) + +(provide 'ob-eshell) + +;;; ob-eshell.el ends here diff --git a/lisp/org/ob-exp.el b/lisp/org/ob-exp.el index 4a5bff82aef..c06e262d71a 100644 --- a/lisp/org/ob-exp.el +++ b/lisp/org/ob-exp.el @@ -32,8 +32,6 @@ (declare-function org-element-type "org-element" (element)) (declare-function org-escape-code-in-string "org-src" (s)) (declare-function org-export-copy-buffer "ox" ()) -(declare-function org-fill-template "org" (template alist)) -(declare-function org-get-indentation "org" (&optional line)) (declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) (defvar org-src-preserve-indentation) @@ -85,7 +83,7 @@ none ---- do not display either code or results upon export Assume point is at block opening line." (interactive) (save-excursion - (let* ((info (org-babel-get-src-block-info 'light)) + (let* ((info (org-babel-get-src-block-info)) (lang (nth 0 info)) (raw-params (nth 2 info)) hash) @@ -108,7 +106,7 @@ Assume point is at block opening line." (symbol-value lang-headers)) (append (org-babel-params-from-properties lang) (list raw-params))))))) - (setf hash (org-babel-sha1-hash info))) + (setf hash (org-babel-sha1-hash info :export))) (org-babel-exp-do-export info 'block hash))))) (defcustom org-babel-exp-call-line-template @@ -210,9 +208,9 @@ this template." (progn (goto-char end) (skip-chars-forward " \t") (point))) - ;; Otherwise: remove inline src block but - ;; preserve following white spaces. Then - ;; insert value. + ;; Otherwise: remove inline source block + ;; but preserve following white spaces. + ;; Then insert value. (delete-region begin end) (insert replacement))))) ((or `babel-call `inline-babel-call) @@ -244,7 +242,7 @@ this template." (insert rep)))) (`src-block (let ((match-start (copy-marker (match-beginning 0))) - (ind (org-get-indentation))) + (ind (current-indentation))) ;; Take care of matched block: compute ;; replacement string. In particular, a nil ;; REPLACEMENT means the block is left as-is diff --git a/lisp/org/ob-forth.el b/lisp/org/ob-forth.el index de42042a5b5..5d4fe304d1b 100644 --- a/lisp/org/ob-forth.el +++ b/lisp/org/ob-forth.el @@ -33,9 +33,9 @@ ;;; Code: (require 'ob) +(require 'org-macs) (declare-function forth-proc "ext:gforth" ()) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-default-header-args:forth '((:session . "yes")) "Default header arguments for forth code blocks.") diff --git a/lisp/org/ob-fortran.el b/lisp/org/ob-fortran.el index 976c611bde4..1431eb40702 100644 --- a/lisp/org/ob-fortran.el +++ b/lisp/org/ob-fortran.el @@ -28,13 +28,12 @@ ;;; Code: (require 'ob) +(require 'org-macs) (require 'cc-mode) (require 'cl-lib) (declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) -(declare-function org-remove-indentation "org" (code &optional n)) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("fortran" . "F90")) @@ -109,7 +108,7 @@ its header arguments." "Wrap body in a \"program ... end program\" block if none exists." (if (string-match "^[ \t]*program[ \t]*.*" (capitalize body)) (let ((vars (org-babel--get-vars params))) - (if vars (error "Cannot use :vars if `program' statement is present")) + (when vars (error "Cannot use :vars if `program' statement is present")) body) (format "program main\n%s\nend program main\n" body))) diff --git a/lisp/org/ob-gnuplot.el b/lisp/org/ob-gnuplot.el index 5ff6756b51e..cc4c3cb23bf 100644 --- a/lisp/org/ob-gnuplot.el +++ b/lisp/org/ob-gnuplot.el @@ -39,9 +39,9 @@ ;;; Code: (require 'ob) +(require 'org-macs) (declare-function org-time-string-to-time "org" (s)) -(declare-function org-combine-plists "org" (&rest plists)) (declare-function orgtbl-to-generic "org-table" (table params)) (declare-function gnuplot-mode "ext:gnuplot-mode" ()) (declare-function gnuplot-send-string-to-gnuplot "ext:gnuplot-mode" (str txt)) diff --git a/lisp/org/ob-haskell.el b/lisp/org/ob-haskell.el index 50d1b57969c..a683b1107f6 100644 --- a/lisp/org/ob-haskell.el +++ b/lisp/org/ob-haskell.el @@ -40,10 +40,9 @@ ;;; Code: (require 'ob) +(require 'org-macs) (require 'comint) -(declare-function org-remove-indentation "org" (code &optional n)) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function haskell-mode "ext:haskell-mode" ()) (declare-function run-haskell "ext:inf-haskell" (&optional arg)) (declare-function inferior-haskell-load-file @@ -75,17 +74,16 @@ (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)) + (cons 'ansi-color-filter-apply comint-preoutput-filter-functions)) (raw (org-babel-comint-with-output (session org-babel-haskell-eoe t full-body) (insert (org-trim full-body)) (comint-send-input nil t) (insert org-babel-haskell-eoe) (comint-send-input nil t))) - (results (mapcar - #'org-babel-strip-quotes - (cdr (member org-babel-haskell-eoe - (reverse (mapcar #'org-trim raw))))))) + (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 diff --git a/lisp/org/ob-js.el b/lisp/org/ob-js.el index dab3aa2fbda..dd53ef69173 100644 --- a/lisp/org/ob-js.el +++ b/lisp/org/ob-js.el @@ -41,6 +41,11 @@ (require 'ob) (declare-function run-mozilla "ext:moz" (arg)) +(declare-function httpd-start "ext:simple-httpd" ()) +(declare-function run-skewer "ext:skewer-mode" ()) +(declare-function skewer-repl "ext:skewer-repl" ()) +(declare-function indium-run-node "ext:indium-nodejs" (command)) +(declare-function indium-eval "ext:indium-interaction" (string &optional callback)) (defvar org-babel-default-header-args:js '() "Default header arguments for js code blocks.") @@ -52,7 +57,12 @@ "Name of command used to evaluate js blocks." :group 'org-babel :version "24.1" - :type 'string) + :type '(choice (const "node") + (const "mozrepl") + (const "skewer-mode") + (const "indium") + (const "js-comint")) + :safe #'stringp) (defvar org-babel-js-function-wrapper "require('sys').print(require('sys').inspect(function(){\n%s\n}()));" @@ -62,22 +72,13 @@ "Execute a block of Javascript code with org-babel. This function is called by `org-babel-execute-src-block'." (let* ((org-babel-js-cmd (or (cdr (assq :cmd params)) org-babel-js-cmd)) + (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:js params))) - (result (if (not (string= (cdr (assq :session params)) "none")) - ;; session evaluation - (let ((session (org-babel-prep-session:js - (cdr (assq :session params)) params))) - (nth 1 - (org-babel-comint-with-output - (session (format "%S" org-babel-js-eoe) t body) - (mapc - (lambda (line) - (insert (org-babel-chomp line)) - (comint-send-input nil t)) - (list body (format "%S" org-babel-js-eoe)))))) - ;; external evaluation + (result (cond + ;; no session specified, external evaluation + ((string= session "none") (let ((script-file (org-babel-temp-file "js-script-"))) (with-temp-file script-file (insert @@ -87,7 +88,24 @@ This function is called by `org-babel-execute-src-block'." full-body))) (org-babel-eval (format "%s %s" org-babel-js-cmd - (org-babel-process-file-name script-file)) ""))))) + (org-babel-process-file-name script-file)) ""))) + ;; Indium Node REPL. Separate case because Indium + ;; REPL is not inherited from Comint mode. + ((string= session "*JS REPL*") + (require 'indium-repl) + (unless (get-buffer session) + (indium-run-node org-babel-js-cmd)) + (indium-eval full-body)) + ;; session evaluation + (t + (let ((session (org-babel-prep-session:js + (cdr (assq :session params)) params))) + (nth 1 + (org-babel-comint-with-output + (session (format "%S" org-babel-js-eoe) t body) + (dolist (code (list body (format "%S" org-babel-js-eoe))) + (insert (org-babel-chomp code)) + (comint-send-input nil t))))))))) (org-babel-result-cond (cdr (assq :result-params params)) result (org-babel-js-read result)))) @@ -123,11 +141,13 @@ specifying a variable of the same value." (var-lines (org-babel-variable-assignments:js params))) (when session (org-babel-comint-in-buffer session - (sit-for .5) (goto-char (point-max)) - (mapc (lambda (var) - (insert var) (comint-send-input nil t) - (org-babel-comint-wait-for-output session) - (sit-for .1) (goto-char (point-max))) var-lines))) + (goto-char (point-max)) + (dolist (var var-lines) + (insert var) + (comint-send-input nil t) + (org-babel-comint-wait-for-output session) + (sit-for .1) + (goto-char (point-max))))) session)) (defun org-babel-variable-assignments:js (params) @@ -137,25 +157,47 @@ specifying a variable of the same value." (car pair) (org-babel-js-var-to-js (cdr pair)))) (org-babel--get-vars params))) -(defun org-babel-js-initiate-session (&optional session) - "If there is not a current inferior-process-buffer in SESSION +(defun org-babel-js-initiate-session (&optional session _params) + "If there is not a current inferior-process-buffer in `SESSION' then create. Return the initialized session." - (unless (string= session "none") - (cond - ((string= "mozrepl" org-babel-js-cmd) - (require 'moz) - (let ((session-buffer (save-window-excursion - (run-mozilla nil) - (rename-buffer session) - (current-buffer)))) - (if (org-babel-comint-buffer-livep session-buffer) - (progn (sit-for .25) session-buffer) - (sit-for .5) - (org-babel-js-initiate-session session)))) - ((string= "node" org-babel-js-cmd ) - (error "Session evaluation with node.js is not supported")) - (t - (error "Sessions are only supported with mozrepl add \":cmd mozrepl\""))))) + (cond + ((string= session "none") + (warn "Session evaluation of ob-js is not supported")) + ((string= "*skewer-repl*" session) + (require 'skewer-repl) + (let ((session-buffer (get-buffer "*skewer-repl*"))) + (if (and session-buffer + (org-babel-comint-buffer-livep (get-buffer session-buffer)) + (comint-check-proc session-buffer)) + session-buffer + ;; start skewer REPL. + (httpd-start) + (run-skewer) + (skewer-repl) + session-buffer))) + ((string= "*Javascript REPL*" session) + (require 'js-comint) + (let ((session-buffer "*Javascript REPL*")) + (if (and (org-babel-comint-buffer-livep (get-buffer session-buffer)) + (comint-check-proc session-buffer)) + session-buffer + (call-interactively 'run-js) + (sit-for .5) + session-buffer))) + ((string= "mozrepl" org-babel-js-cmd) + (require 'moz) + (let ((session-buffer (save-window-excursion + (run-mozilla nil) + (rename-buffer session) + (current-buffer)))) + (if (org-babel-comint-buffer-livep session-buffer) + (progn (sit-for .25) session-buffer) + (sit-for .5) + (org-babel-js-initiate-session session)))) + ((string= "node" org-babel-js-cmd ) + (error "Session evaluation with node.js is not supported")) + (t + (error "Sessions are only supported with mozrepl add \":cmd mozrepl\"")))) (provide 'ob-js) diff --git a/lisp/org/ob-keys.el b/lisp/org/ob-keys.el deleted file mode 100644 index 627648d28ab..00000000000 --- a/lisp/org/ob-keys.el +++ /dev/null @@ -1,106 +0,0 @@ -;;; ob-keys.el --- Key Bindings for Babel -*- lexical-binding: t; -*- - -;; Copyright (C) 2009-2019 Free Software Foundation, Inc. - -;; Author: Eric Schulte -;; Keywords: literate programming, reproducible research -;; Homepage: https://orgmode.org - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Add Org Babel keybindings to the Org mode keymap for exposing -;; Org Babel functions. These will all share a common prefix. See -;; the value of `org-babel-key-bindings' for a list of interactive -;; functions and their associated keys. - -;;; Code: -(require 'ob-core) - -(defvar org-babel-key-prefix "\C-c\C-v" - "The key prefix for Babel interactive key-bindings. -See `org-babel-key-bindings' for the list of interactive babel -functions which are assigned key bindings, and see -`org-babel-map' for the actual babel keymap.") - -(defvar org-babel-map (make-sparse-keymap) - "The keymap for interactive Babel functions.") - -;;;###autoload -(defun org-babel-describe-bindings () - "Describe all keybindings behind `org-babel-key-prefix'." - (interactive) - (describe-bindings org-babel-key-prefix)) - -(defvar org-babel-key-bindings - '(("p" . org-babel-previous-src-block) - ("\C-p" . org-babel-previous-src-block) - ("n" . org-babel-next-src-block) - ("\C-n" . org-babel-next-src-block) - ("e" . org-babel-execute-maybe) - ("\C-e" . org-babel-execute-maybe) - ("o" . org-babel-open-src-block-result) - ("\C-o" . org-babel-open-src-block-result) - ("\C-v" . org-babel-expand-src-block) - ("v" . org-babel-expand-src-block) - ("u" . org-babel-goto-src-block-head) - ("\C-u" . org-babel-goto-src-block-head) - ("g" . org-babel-goto-named-src-block) - ("r" . org-babel-goto-named-result) - ("\C-r" . org-babel-goto-named-result) - ("\C-b" . org-babel-execute-buffer) - ("b" . org-babel-execute-buffer) - ("\C-s" . org-babel-execute-subtree) - ("s" . org-babel-execute-subtree) - ("\C-d" . org-babel-demarcate-block) - ("d" . org-babel-demarcate-block) - ("\C-t" . org-babel-tangle) - ("t" . org-babel-tangle) - ("\C-f" . org-babel-tangle-file) - ("f" . org-babel-tangle-file) - ("\C-c" . org-babel-check-src-block) - ("c" . org-babel-check-src-block) - ("\C-j" . org-babel-insert-header-arg) - ("j" . org-babel-insert-header-arg) - ("\C-l" . org-babel-load-in-session) - ("l" . org-babel-load-in-session) - ("\C-i" . org-babel-lob-ingest) - ("i" . org-babel-lob-ingest) - ("\C-I" . org-babel-view-src-block-info) - ("I" . org-babel-view-src-block-info) - ("\C-z" . org-babel-switch-to-session) - ("z" . org-babel-switch-to-session-with-code) - ("\C-a" . org-babel-sha1-hash) - ("a" . org-babel-sha1-hash) - ("h" . org-babel-describe-bindings) - ("\C-x" . org-babel-do-key-sequence-in-edit-buffer) - ("x" . org-babel-do-key-sequence-in-edit-buffer) - ("k" . org-babel-remove-result-one-or-many) - ("\C-\M-h" . org-babel-mark-block)) - "Alist of key bindings and interactive Babel functions. -This list associates interactive Babel functions -with keys. Each element of this list will add an entry to the -`org-babel-map' using the letter key which is the `car' of the -a-list placed behind the generic `org-babel-key-prefix'.") - -(provide 'ob-keys) - -;; Local variables: -;; generated-autoload-file: "org-loaddefs.el" -;; End: - -;;; ob-keys.el ends here diff --git a/lisp/org/ob-latex.el b/lisp/org/ob-latex.el index 219b11c05a8..adf83d46038 100644 --- a/lisp/org/ob-latex.el +++ b/lisp/org/ob-latex.el @@ -31,12 +31,12 @@ ;;; Code: (require 'ob) +(require 'org-macs) (declare-function org-create-formula-image "org" (string tofile options buffer &optional type)) (declare-function org-latex-compile "ox-latex" (texfile &optional snippet)) (declare-function org-latex-guess-inputenc "ox-latex" (header)) (declare-function org-splice-latex-header "org" (tpl def-pkg pkg snippets-p &optional extra)) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("latex" . "tex")) diff --git a/lisp/org/ob-lilypond.el b/lisp/org/ob-lilypond.el index c07ae784600..4538ed5cb72 100644 --- a/lisp/org/ob-lilypond.el +++ b/lisp/org/ob-lilypond.el @@ -33,7 +33,9 @@ ;;; Code: (require 'ob) -(require 'outline) + +(declare-function org-show-all "org" (&optional types)) + (defalias 'lilypond-mode 'LilyPond-mode) (add-to-list 'org-babel-tangle-lang-exts '("LilyPond" . "ly")) @@ -264,7 +266,7 @@ LINE is the erroneous line." (setq case-fold-search nil) (if (search-forward line nil t) (progn - (outline-show-all) + (org-show-all) (set-mark (point)) (goto-char (- (point) (length line)))) (goto-char temp)))) diff --git a/lisp/org/ob-lisp.el b/lisp/org/ob-lisp.el index 6fef0dada37..398ed2191b1 100644 --- a/lisp/org/ob-lisp.el +++ b/lisp/org/ob-lisp.el @@ -37,10 +37,10 @@ ;;; Code: (require 'ob) +(require 'org-macs) (declare-function sly-eval "ext:sly" (sexp &optional package)) (declare-function slime-eval "ext:slime" (sexp &optional package)) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("lisp" . "lisp")) @@ -107,7 +107,7 @@ a property list containing the parameters of the block." (point-min) (point-max))))) (cdr (assq :package params))))))) (org-babel-result-cond (cdr (assq :result-params params)) - result + (org-strip-quotes result) (condition-case nil (read (org-babel-lisp-vector-to-list result)) (error result)))) diff --git a/lisp/org/ob-lob.el b/lisp/org/ob-lob.el index 4197f2d258d..a6194c4bc67 100644 --- a/lisp/org/ob-lob.el +++ b/lisp/org/ob-lob.el @@ -62,7 +62,7 @@ should not be inherited from a source block.") (cons (cons source info) (assq-delete-all source org-babel-library-of-babel)))) (cl-incf lob-ingest-count)))) - (message "%d src block%s added to Library of Babel" + (message "%d source block%s added to Library of Babel" lob-ingest-count (if (> lob-ingest-count 1) "s" "")) lob-ingest-count)) @@ -138,9 +138,8 @@ see." header org-babel-default-lob-header-args (append - (org-with-wide-buffer - (goto-char begin) - (org-babel-params-from-properties language)) + (org-with-point-at begin + (org-babel-params-from-properties language)) (list (org-babel-parse-header-arguments (org-element-property :inside-header context)) diff --git a/lisp/org/ob-lua.el b/lisp/org/ob-lua.el index 8712619ecc6..530376a41d3 100644 --- a/lisp/org/ob-lua.el +++ b/lisp/org/ob-lua.el @@ -34,10 +34,9 @@ ;;; Code: (require 'ob) +(require 'org-macs) (require 'cl-lib) -(declare-function org-remove-indentation "org" (code &optional n)) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function lua-shell "ext:lua-mode" (&optional argprompt)) (declare-function lua-toggle-shells "ext:lua-mode" (arg)) (declare-function run-lua "ext:lua" (cmd &optional dedicated show)) @@ -149,7 +148,7 @@ specifying a variable of the same value." (if (eq var 'hline) org-babel-lua-hline-to (format - (if (and (stringp var) (string-match "[\n\r]" var)) "\"\"%S\"\"" "%S") + (if (and (stringp var) (string-match "[\n\r]" var)) "[=[%s]=]" "%S") (if (stringp var) (substring-no-properties var) var))))) (defun org-babel-lua-table-or-string (results) @@ -291,13 +290,13 @@ last statement in BODY, as elisp." (let ((raw (pcase result-type (`output (org-babel-eval org-babel-lua-command - (concat (if preamble (concat preamble "\n")) + (concat preamble (and preamble "\n") body))) (`value (let ((tmp-file (org-babel-temp-file "lua-"))) (org-babel-eval org-babel-lua-command (concat - (if preamble (concat preamble "\n") "") + preamble (and preamble "\n") (format (if (member "pp" result-params) org-babel-lua-pp-wrapper-method diff --git a/lisp/org/ob-ocaml.el b/lisp/org/ob-ocaml.el index e8f801b992f..54bc49a2ff9 100644 --- a/lisp/org/ob-ocaml.el +++ b/lisp/org/ob-ocaml.el @@ -37,11 +37,11 @@ ;;; Code: (require 'ob) (require 'comint) +(require 'org-macs) (declare-function tuareg-run-caml "ext:tuareg" ()) (declare-function tuareg-run-ocaml "ext:tuareg" ()) (declare-function tuareg-interactive-send-input "ext:tuareg" ()) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-tangle-lang-exts) (add-to-list 'org-babel-tangle-lang-exts '("ocaml" . "ml")) @@ -83,11 +83,11 @@ (raw (org-trim clean)) (result-params (cdr (assq :result-params params)))) (string-match - "\\(\\(.*\n\\)*\\)[^:\n]+ : \\([^=\n]+\\) =\\(\n\\| \\)\\(.+\\)$" + "\\(\\(.*\n\\)*\\)[^:\n]+ : \\([^=\n]+\\) =[[:space:]]+\\(\\(.\\|\n\\)+\\)$" raw) (let ((output (match-string 1 raw)) (type (match-string 3 raw)) - (value (match-string 5 raw))) + (value (match-string 4 raw))) (org-babel-reassemble-table (org-babel-result-cond result-params (cond diff --git a/lisp/org/ob-octave.el b/lisp/org/ob-octave.el index 28c7ad2dd0a..d334fa514ec 100644 --- a/lisp/org/ob-octave.el +++ b/lisp/org/ob-octave.el @@ -30,10 +30,10 @@ ;;; Code: (require 'ob) +(require 'org-macs) (declare-function matlab-shell "ext:matlab-mode") (declare-function matlab-shell-run-region "ext:matlab-mode") -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-default-header-args:matlab '()) (defvar org-babel-default-header-args:octave '()) @@ -237,13 +237,11 @@ value of the last statement in BODY, as elisp." (`output (setq results (if matlabp - (cdr (reverse (delq "" (mapcar - #'org-babel-strip-quotes - (mapcar #'org-trim raw))))) + (cdr (reverse (delq "" (mapcar #'org-strip-quotes + (mapcar #'org-trim raw))))) (cdr (member org-babel-octave-eoe-output - (reverse (mapcar - #'org-babel-strip-quotes - (mapcar #'org-trim raw))))))) + (reverse (mapcar #'org-strip-quotes + (mapcar #'org-trim raw))))))) (mapconcat #'identity (reverse results) "\n"))))) (defun org-babel-octave-import-elisp-from-file (file-name) @@ -254,9 +252,9 @@ This removes initial blank and comment lines and then calls (with-temp-file temp-file (insert-file-contents file-name) (re-search-forward "^[ \t]*[^# \t]" nil t) - (if (< (setq beg (point-min)) - (setq end (point-at-bol))) - (delete-region beg end))) + (when (< (setq beg (point-min)) + (setq end (point-at-bol))) + (delete-region beg end))) (org-babel-import-elisp-from-file temp-file '(16)))) (provide 'ob-octave) diff --git a/lisp/org/ob-plantuml.el b/lisp/org/ob-plantuml.el index 91229a29497..09c9a333463 100644 --- a/lisp/org/ob-plantuml.el +++ b/lisp/org/ob-plantuml.el @@ -60,16 +60,19 @@ are expected to be scalar variables." (defun org-babel-plantuml-make-body (body params) "Return PlantUML input string. + BODY is the content of the source block and PARAMS is a property list of source block parameters. This function relies on the `org-babel-expand-body:generic' function to extract `:var' entries from PARAMS and on the `org-babel-variable-assignments:plantuml' -function to convert variables to PlantUML assignments." - (concat - "@startuml\n" - (org-babel-expand-body:generic - body params (org-babel-variable-assignments:plantuml params)) - "\n@enduml")) +function to convert variables to PlantUML assignments. + +If BODY does not contain @startXXX ... @endXXX clauses, @startuml +... @enduml will be added." + (let ((assignments (org-babel-variable-assignments:plantuml params))) + (if (string-prefix-p "@start" body t) assignments + (format "@startuml\n%s\n@enduml" + (org-babel-expand-body:generic body params assignments))))) (defun org-babel-execute:plantuml (body params) "Execute a block of plantuml code with org-babel. @@ -93,6 +96,8 @@ This function is called by `org-babel-execute-src-block'." " -teps" "") (if (string= (file-name-extension out-file) "pdf") " -tpdf" "") + (if (string= (file-name-extension out-file) "tex") + " -tlatex" "") (if (string= (file-name-extension out-file) "vdx") " -tvdx" "") (if (string= (file-name-extension out-file) "xmi") diff --git a/lisp/org/ob-python.el b/lisp/org/ob-python.el index b10320ee532..c36bf2dcd0f 100644 --- a/lisp/org/ob-python.el +++ b/lisp/org/ob-python.el @@ -28,9 +28,8 @@ ;;; Code: (require 'ob) +(require 'org-macs) -(declare-function org-remove-indentation "org" ) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function py-shell "ext:python-mode" (&optional argprompt)) (declare-function py-toggle-shells "ext:python-mode" (arg)) (declare-function run-python "ext:python" (&optional cmd dedicated show)) @@ -266,13 +265,13 @@ last statement in BODY, as elisp." (let ((raw (pcase result-type (`output (org-babel-eval org-babel-python-command - (concat (if preamble (concat preamble "\n")) + (concat preamble (and preamble "\n") body))) (`value (let ((tmp-file (org-babel-temp-file "python-"))) (org-babel-eval org-babel-python-command (concat - (if preamble (concat preamble "\n") "") + preamble (and preamble "\n") (format (if (member "pp" result-params) org-babel-python-pp-wrapper-method @@ -308,9 +307,21 @@ last statement in BODY, as elisp." (list (format "open('%s', 'w').write(str(_))" (org-babel-process-file-name tmp-file 'noquote))))))) + (last-indent 0) (input-body (lambda (body) - (mapc (lambda (line) (insert line) (funcall send-wait)) - (split-string body "[\r\n]")) + (dolist (line (split-string body "[\r\n]")) + ;; Insert a blank line to end an indent + ;; block. + (let ((curr-indent (string-match "\\S-" line))) + (if curr-indent + (progn + (when (< curr-indent last-indent) + (insert "") + (funcall send-wait)) + (setq last-indent curr-indent)) + (setq last-indent 0))) + (insert line) + (funcall send-wait)) (funcall send-wait))) (results (pcase result-type diff --git a/lisp/org/ob-ref.el b/lisp/org/ob-ref.el index 2198a84f4c1..8c066f712b2 100644 --- a/lisp/org/ob-ref.el +++ b/lisp/org/ob-ref.el @@ -37,8 +37,8 @@ ;; - resource-id :: the id or name of the resource -;; So an example of a simple src block referencing table data in the -;; same file would be +;; So an example of a simple source block referencing table data in +;; the same file would be ;; #+NAME: sandbox ;; | 1 | 2 | 3 | @@ -50,6 +50,7 @@ ;;; Code: (require 'ob-core) +(require 'org-macs) (require 'cl-lib) (declare-function org-babel-lob-get-info "ob-lob" (&optional datum)) @@ -63,7 +64,6 @@ (declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) (declare-function org-narrow-to-subtree "org" ()) (declare-function org-show-context "org" (&optional key)) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-babel-update-intermediate nil "Update the in-buffer results of code blocks executed to resolve references.") diff --git a/lisp/org/ob-ruby.el b/lisp/org/ob-ruby.el index 309bd15a00a..be76727a109 100644 --- a/lisp/org/ob-ruby.el +++ b/lisp/org/ob-ruby.el @@ -37,8 +37,8 @@ ;;; Code: (require 'ob) +(require 'org-macs) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function run-ruby "ext:inf-ruby" (&optional command name)) (declare-function xmp "ext:rcodetools" (&optional option)) diff --git a/lisp/org/ob-scheme.el b/lisp/org/ob-scheme.el index 635b3aa6003..21d9fad2b6b 100644 --- a/lisp/org/ob-scheme.el +++ b/lisp/org/ob-scheme.el @@ -112,10 +112,9 @@ (or buffer (progn (run-geiser impl) - (if name - (progn - (rename-buffer name t) - (org-babel-scheme-set-session-buffer name (current-buffer)))) + (when name + (rename-buffer name t) + (org-babel-scheme-set-session-buffer name (current-buffer))) (current-buffer))))) (defun org-babel-scheme-make-session-name (buffer name impl) @@ -214,6 +213,7 @@ This function is called by `org-babel-execute-src-block'." (session (org-babel-scheme-make-session-name source-buffer-name (cdr (assq :session params)) impl)) (full-body (org-babel-expand-body:scheme body params)) + (result-params (cdr (assq :result-params params))) (result (org-babel-scheme-execute-with-geiser full-body ; code @@ -227,7 +227,9 @@ This function is called by `org-babel-execute-src-block'." (cdr (assq :colnames params))) (org-babel-pick-name (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))) - (org-babel-scheme--table-or-string table)))))) + (org-babel-result-cond result-params + result + (org-babel-scheme--table-or-string table))))))) (provide 'ob-scheme) diff --git a/lisp/org/ob-sed.el b/lisp/org/ob-sed.el index 33751b8533c..be4cff48a54 100644 --- a/lisp/org/ob-sed.el +++ b/lisp/org/ob-sed.el @@ -4,7 +4,7 @@ ;; Author: Bjarte Johansen ;; Keywords: literate programming, reproducible research -;; Version: 0.1.0 +;; Version: 0.1.1 ;; This file is part of GNU Emacs. @@ -79,7 +79,7 @@ function is called by `org-babel-execute-src-block'." (cmd (mapconcat #'identity (remq nil (list org-babel-sed-command - (format "--file=\"%s\"" code-file) + (format "-f \"%s\"" code-file) cmd-line in-file)) " "))) diff --git a/lisp/org/ob-shell.el b/lisp/org/ob-shell.el index 548edce5793..88342bab74d 100644 --- a/lisp/org/ob-shell.el +++ b/lisp/org/ob-shell.el @@ -27,6 +27,7 @@ ;;; Code: (require 'ob) +(require 'org-macs) (require 'shell) (require 'cl-lib) @@ -36,7 +37,6 @@ (declare-function org-babel-comint-buffer-livep "ob-comint" (buffer)) (declare-function org-babel-comint-with-output "ob-comint" (meta &rest body) t) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function orgtbl-to-generic "org-table" (table params)) (defvar org-babel-default-header-args:shell '()) @@ -57,10 +57,11 @@ is modified outside the Customize interface." 'org-babel-variable-assignments:shell ,(format "Return list of %s statements assigning to the block's \ variables." - name))))) + name))) + (eval `(defvar ,(intern (concat "org-babel-default-header-args:" name)) '())))) (defcustom org-babel-shell-names - '("sh" "bash" "csh" "ash" "dash" "ksh" "mksh" "posh") + '("sh" "bash" "zsh" "fish" "csh" "ash" "dash" "ksh" "mksh" "posh") "List of names of shell supported by babel shell code blocks. Call `org-babel-shell-initialize' when modifying this variable outside the Customize interface." @@ -206,62 +207,60 @@ var of the same value." If RESULT-TYPE equals `output' then return a list of the outputs of the statements in BODY, if RESULT-TYPE equals `value' then return the value of the last statement in BODY." - (let ((results - (cond - ((or stdin cmdline) ; external shell script w/STDIN - (let ((script-file (org-babel-temp-file "sh-script-")) - (stdin-file (org-babel-temp-file "sh-stdin-")) - (shebang (cdr (assq :shebang params))) - (padline (not (string= "no" (cdr (assq :padline params)))))) - (with-temp-file script-file - (when shebang (insert (concat shebang "\n"))) - (when padline (insert "\n")) - (insert body)) - (set-file-modes script-file #o755) - (with-temp-file stdin-file (insert (or stdin ""))) - (with-temp-buffer - (call-process-shell-command - (concat (if shebang script-file - (format "%s %s" shell-file-name script-file)) - (and cmdline (concat " " cmdline))) - stdin-file - (current-buffer)) - (buffer-string)))) - (session ; session evaluation - (mapconcat - #'org-babel-sh-strip-weird-long-prompt - (mapcar - #'org-trim - (butlast - (org-babel-comint-with-output - (session org-babel-sh-eoe-output t body) - (mapc - (lambda (line) - (insert line) - (comint-send-input nil t) - (while (save-excursion - (goto-char comint-last-input-end) - (not (re-search-forward - comint-prompt-regexp nil t))) - (accept-process-output - (get-buffer-process (current-buffer))))) - (append - (split-string (org-trim body) "\n") - (list org-babel-sh-eoe-indicator)))) - 2)) "\n")) - ('otherwise ; external shell script - (if (and (cdr (assq :shebang params)) - (> (length (cdr (assq :shebang params))) 0)) - (let ((script-file (org-babel-temp-file "sh-script-")) - (shebang (cdr (assq :shebang params))) - (padline (not (equal "no" (cdr (assq :padline params)))))) - (with-temp-file script-file - (when shebang (insert (concat shebang "\n"))) - (when padline (insert "\n")) - (insert body)) - (set-file-modes script-file #o755) - (org-babel-eval script-file "")) - (org-babel-eval shell-file-name (org-trim body))))))) + (let* ((shebang (cdr (assq :shebang params))) + (results + (cond + ((or stdin cmdline) ; external shell script w/STDIN + (let ((script-file (org-babel-temp-file "sh-script-")) + (stdin-file (org-babel-temp-file "sh-stdin-")) + (padline (not (string= "no" (cdr (assq :padline params)))))) + (with-temp-file script-file + (when shebang (insert shebang "\n")) + (when padline (insert "\n")) + (insert body)) + (set-file-modes script-file #o755) + (with-temp-file stdin-file (insert (or stdin ""))) + (with-temp-buffer + (call-process-shell-command + (concat (if shebang script-file + (format "%s %s" shell-file-name script-file)) + (and cmdline (concat " " cmdline))) + stdin-file + (current-buffer)) + (buffer-string)))) + (session ; session evaluation + (mapconcat + #'org-babel-sh-strip-weird-long-prompt + (mapcar + #'org-trim + (butlast + (org-babel-comint-with-output + (session org-babel-sh-eoe-output t body) + (dolist (line (append (split-string (org-trim body) "\n") + (list org-babel-sh-eoe-indicator))) + (insert line) + (comint-send-input nil t) + (while (save-excursion + (goto-char comint-last-input-end) + (not (re-search-forward + comint-prompt-regexp nil t))) + (accept-process-output + (get-buffer-process (current-buffer)))))) + 2)) + "\n")) + ;; External shell script, with or without a predefined + ;; shebang. + ((org-string-nw-p shebang) + (let ((script-file (org-babel-temp-file "sh-script-")) + (padline (not (equal "no" (cdr (assq :padline params)))))) + (with-temp-file script-file + (insert shebang "\n") + (when padline (insert "\n")) + (insert body)) + (set-file-modes script-file #o755) + (org-babel-eval script-file ""))) + (t + (org-babel-eval shell-file-name (org-trim body)))))) (when results (let ((result-params (cdr (assq :result-params params)))) (org-babel-result-cond result-params diff --git a/lisp/org/ob-sql.el b/lisp/org/ob-sql.el index 17447b41f55..1bbfd44528c 100644 --- a/lisp/org/ob-sql.el +++ b/lisp/org/ob-sql.el @@ -39,6 +39,7 @@ ;; - dbport ;; - dbuser ;; - dbpassword +;; - dbconnection (to reference connections in sql-connection-alist) ;; - database ;; - colnames (default, nil, means "yes") ;; - result-params @@ -73,6 +74,7 @@ (declare-function org-table-to-lisp "org-table" (&optional txt)) (declare-function cygwin-convert-file-name-to-windows "cygw32.c" (file &optional absolute-p)) +(defvar sql-connection-alist) (defvar org-babel-default-header-args:sql '()) (defconst org-babel-header-args:sql @@ -111,8 +113,24 @@ Pass nil to omit that arg." (when database (concat "-d" database)))))) (defun org-babel-sql-dbstring-oracle (host port user password database) - "Make Oracle command line args for database connection." - (format "%s/%s@%s:%s/%s" user password host port database)) + "Make Oracle command line arguments for database connection. + +If HOST and PORT are nil then don't pass them. This allows you +to use names defined in your \"TNSNAMES\" file. So you can +connect with + + <user>/<password>@<host>:<port>/<database> + +or + + <user>/<password>@<database> + +using its alias." + (cond ((and user password database host port) + (format "%s/%s@%s:%s/%s" user password host port database)) + ((and user password database) + (format "%s/%s@%s" user password database)) + (t (user-error "Missing information to connect to database")))) (defun org-babel-sql-dbstring-mssql (host user password database) "Make sqlcmd command line args for database connection. @@ -158,16 +176,35 @@ Otherwise, use Emacs' standard conversion function." ((string= "windows-nt" system-type) file) (t (format "%S" (convert-standard-filename file))))) +(defun org-babel-find-db-connection-param (params name) + "Return database connection parameter NAME. +Given a parameter NAME, if :dbconnection is defined in PARAMS +then look for the parameter into the corresponding connection +defined in `sql-connection-alist`, otherwise look into PARAMS. +Look `sql-connection-alist` (part of SQL mode) for how to define +database connections." + (if (assq :dbconnection params) + (let* ((dbconnection (cdr (assq :dbconnection params))) + (name-mapping '((:dbhost . sql-server) + (:dbport . sql-port) + (:dbuser . sql-user) + (:dbpassword . sql-password) + (:database . sql-database))) + (mapped-name (cdr (assq name name-mapping)))) + (cadr (assq mapped-name + (cdr (assoc dbconnection sql-connection-alist))))) + (cdr (assq name params)))) + (defun org-babel-execute:sql (body params) "Execute a block of Sql code with Babel. This function is called by `org-babel-execute-src-block'." (let* ((result-params (cdr (assq :result-params params))) (cmdline (cdr (assq :cmdline params))) - (dbhost (cdr (assq :dbhost params))) - (dbport (cdr (assq :dbport params))) - (dbuser (cdr (assq :dbuser params))) - (dbpassword (cdr (assq :dbpassword params))) - (database (cdr (assq :database params))) + (dbhost (org-babel-find-db-connection-param params :dbhost)) + (dbport (org-babel-find-db-connection-param params :dbport)) + (dbuser (org-babel-find-db-connection-param params :dbuser)) + (dbpassword (org-babel-find-db-connection-param params :dbpassword)) + (database (org-babel-find-db-connection-param params :database)) (engine (cdr (assq :engine params))) (colnames-p (not (equal "no" (cdr (assq :colnames params))))) (in-file (org-babel-temp-file "sql-in-")) @@ -241,6 +278,7 @@ SET NEWPAGE 0 SET TAB OFF SET SPACE 0 SET LINESIZE 9999 +SET TRIMOUT ON TRIMSPOOL ON SET ECHO OFF SET FEEDBACK OFF SET VERIFY OFF diff --git a/lisp/org/ob-sqlite.el b/lisp/org/ob-sqlite.el index 04bf4fe23fc..7522c8361fa 100644 --- a/lisp/org/ob-sqlite.el +++ b/lisp/org/ob-sqlite.el @@ -28,7 +28,6 @@ ;;; Code: (require 'ob) -(declare-function org-fill-template "org" (template alist)) (declare-function org-table-convert-region "org-table" (beg0 end0 &optional separator)) (declare-function orgtbl-to-csv "org-table" (table params)) diff --git a/lisp/org/ob-table.el b/lisp/org/ob-table.el index 93a8165167a..42eecea1f6c 100644 --- a/lisp/org/ob-table.el +++ b/lisp/org/ob-table.el @@ -54,8 +54,7 @@ ;;; Code: (require 'ob-core) - -(declare-function org-trim "org" (s &optional keep-lead)) +(require 'org-macs) (defun org-babel-table-truncate-at-newline (string) "Replace newline character with ellipses. diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el index 3c162001cd1..2ea33418225 100644 --- a/lisp/org/ob-tangle.el +++ b/lisp/org/ob-tangle.el @@ -30,6 +30,7 @@ (require 'cl-lib) (require 'org-src) (require 'org-macs) +(require 'ol) (declare-function make-directory "files" (dir &optional parents)) (declare-function org-at-heading-p "org" (&optional ignored)) @@ -38,18 +39,9 @@ (declare-function org-before-first-heading-p "org" ()) (declare-function org-element-at-point "org-element" ()) (declare-function org-element-type "org-element" (element)) -(declare-function org-fill-template "org" (template alist)) (declare-function org-heading-components "org" ()) (declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) -(declare-function org-link-escape "org" (text &optional table merge)) -(declare-function org-open-link-from-string "org" (s &optional arg reference-buffer)) -(declare-function org-remove-indentation "org" (code &optional n)) -(declare-function org-store-link "org" (arg)) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function outline-previous-heading "outline" ()) -(declare-function org-id-find "org-id" (id &optional markerp)) - -(defvar org-link-types-re) (defcustom org-babel-tangle-lang-exts '(("emacs-lisp" . "el") @@ -182,7 +174,7 @@ export file for all source blocks. Optional argument LANG can be used to limit the exported source code blocks by language. Return a list whose CAR is the tangled file name." (interactive "fFile to tangle: \nP") - (let ((visited-p (get-file-buffer (expand-file-name file))) + (let ((visited-p (find-buffer-visiting (expand-file-name file))) to-be-removed) (prog1 (save-window-excursion @@ -236,13 +228,7 @@ used to limit the exported source code blocks by language." (let* ((lang (car by-lang)) (specs (cdr by-lang)) (ext (or (cdr (assoc lang org-babel-tangle-lang-exts)) lang)) - (lang-f (intern - (concat - (or (and (cdr (assoc lang org-src-lang-modes)) - (symbol-name - (cdr (assoc lang org-src-lang-modes)))) - lang) - "-mode"))) + (lang-f (org-src-get-lang-mode lang)) she-banged) (mapc (lambda (spec) @@ -333,8 +319,6 @@ references." (delete-region (save-excursion (beginning-of-line 1) (point)) (save-excursion (end-of-line 1) (forward-char 1) (point))))) -(defvar org-stored-links) -(defvar org-bracket-link-regexp) (defun org-babel-spec-to-string (spec) "Insert SPEC into the current file. @@ -409,7 +393,8 @@ can be used to limit the collected code blocks by target file." (if by-lang (setcdr by-lang (cons block (cdr by-lang))) (push (cons src-lang (list block)) blocks))))))) ;; Ensure blocks are in the correct order. - (mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) blocks))) + (mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) + (nreverse blocks)))) (defun org-babel-tangle-single-block (block-counter &optional only-this-block) "Collect the tangled source for current block. @@ -429,7 +414,7 @@ non-nil, return the full association list to be used by (match-string 1 extra)) org-coderef-label-format)) (link (let ((l (org-no-properties (org-store-link nil)))) - (and (string-match org-bracket-link-regexp l) + (and (string-match org-link-bracket-re l) (match-string 1 l)))) (source-name (or (nth 4 info) @@ -503,22 +488,21 @@ non-nil, return the full association list to be used by result))) (defun org-babel-tangle-comment-links (&optional info) - "Return a list of begin and end link comments for the code block at point." - (let ((link-data - `(("start-line" . ,(number-to-string - (org-babel-where-is-src-block-head))) - ("file" . ,(buffer-file-name)) - ("link" . ,(org-link-escape - (progn - (call-interactively #'org-store-link) - (org-no-properties (car (pop org-stored-links)))))) - ("source-name" . - ,(nth 4 (or info (org-babel-get-src-block-info 'light))))))) + "Return a list of begin and end link comments for the code block at point. +INFO, when non nil, is the source block information, as returned +by `org-babel-get-src-block-info'." + (let ((link-data (pcase (or info (org-babel-get-src-block-info 'light)) + (`(,_ ,_ ,_ ,_ ,name ,start ,_) + `(("start-line" . ,(org-with-point-at start + (number-to-string + (line-number-at-pos)))) + ("file" . ,(buffer-file-name)) + ("link" . ,(org-no-properties (org-store-link nil))) + ("source-name" . ,name)))))) (list (org-fill-template org-babel-tangle-comment-format-beg link-data) (org-fill-template org-babel-tangle-comment-format-end link-data)))) ;; de-tangling functions -(defvar org-bracket-link-analytic-regexp) (defun org-babel-detangle (&optional source-code-file) "Propagate changes in source file back original to Org file. This requires that code blocks were tangled with link comments @@ -528,9 +512,9 @@ which enable the original code blocks to be found." (when source-code-file (find-file source-code-file)) (goto-char (point-min)) (let ((counter 0) new-body end) - (while (re-search-forward org-bracket-link-analytic-regexp nil t) + (while (re-search-forward org-link-bracket-re nil t) (when (re-search-forward - (concat " " (regexp-quote (match-string 5)) " ends here")) + (concat " " (regexp-quote (match-string 2)) " ends here")) (setq end (match-end 0)) (forward-line -1) (save-excursion @@ -544,17 +528,15 @@ which enable the original code blocks to be found." "Jump from a tangled code file to the related Org mode file." (interactive) (let ((mid (point)) - start body-start end - target-buffer target-char link path block-name body) + start body-start end target-buffer target-char link block-name body) (save-window-excursion (save-excursion - (while (and (re-search-backward org-bracket-link-analytic-regexp nil t) + (while (and (re-search-backward org-link-bracket-re nil t) (not ; ever wider searches until matching block comments (and (setq start (line-beginning-position)) (setq body-start (line-beginning-position 2)) (setq link (match-string 0)) - (setq path (match-string 3)) - (setq block-name (match-string 5)) + (setq block-name (match-string 2)) (save-excursion (save-match-data (re-search-forward @@ -564,12 +546,9 @@ which enable the original code blocks to be found." (unless (and start (< start mid) (< mid end)) (error "Not in tangled code")) (setq body (buffer-substring body-start end))) - (when (string-match "::" path) - (setq path (substring path 0 (match-beginning 0)))) - (find-file (or (car (org-id-find path)) path)) - (setq target-buffer (current-buffer)) ;; Go to the beginning of the relative block in Org file. - (org-open-link-from-string link) + (org-link-open-from-string link) + (setq target-buffer (current-buffer)) (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name) (let ((n (string-to-number (match-string 1 block-name)))) (if (org-before-first-heading-p) (goto-char (point-min)) @@ -583,10 +562,12 @@ which enable the original code blocks to be found." (t (org-babel-next-src-block (1- n))))) (org-babel-goto-named-src-block block-name)) (goto-char (org-babel-where-is-src-block-head)) - ;; Preserve location of point within the source code in tangled - ;; code file. (forward-line 1) - (forward-char (- mid body-start)) + ;; Try to preserve location of point within the source code in + ;; tangled code file. + (let ((offset (- mid body-start))) + (when (> end (+ offset (point))) + (forward-char offset))) (setq target-char (point))) (org-src-switch-to-buffer target-buffer t) (goto-char target-char) diff --git a/lisp/org/ob-vala.el b/lisp/org/ob-vala.el index 5d1400268e0..85868d8e336 100644 --- a/lisp/org/ob-vala.el +++ b/lisp/org/ob-vala.el @@ -39,8 +39,7 @@ ;;; Code: (require 'ob) - -(declare-function org-trim "org" (s &optional keep-lead)) +(require 'org-macs) ;; File extension. (add-to-list 'org-babel-tangle-lang-exts '("vala" . "vala")) diff --git a/lisp/org/ob.el b/lisp/org/ob.el index 86d6928b553..6dffa23e2da 100644 --- a/lisp/org/ob.el +++ b/lisp/org/ob.el @@ -24,11 +24,11 @@ ;;; Code: (require 'org-macs) (require 'org-compat) +(require 'org-keys) (require 'ob-eval) (require 'ob-core) (require 'ob-comint) (require 'ob-exp) -(require 'ob-keys) (require 'ob-table) (require 'ob-lob) (require 'ob-ref) diff --git a/lisp/org/org-bbdb.el b/lisp/org/ol-bbdb.el index 2c4f126d08b..b4940ac7b17 100644 --- a/lisp/org/org-bbdb.el +++ b/lisp/org/ol-bbdb.el @@ -1,4 +1,4 @@ -;;; org-bbdb.el --- Support for links to BBDB entries -*- lexical-binding: t; -*- +;;; ol-bbdb.el --- Links to BBDB entries -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2019 Free Software Foundation, Inc. @@ -93,23 +93,22 @@ ;; ;;; Code: -(require 'org) (require 'cl-lib) +(require 'org-compat) +(require 'org-macs) +(require 'ol) -;; Declare external functions and variables +;; Declare functions and variables (declare-function bbdb "ext:bbdb-com" (string elidep)) (declare-function bbdb-company "ext:bbdb-com" (string elidep)) -(declare-function bbdb-current-record "ext:bbdb-com" - (&optional planning-on-modifying)) +(declare-function bbdb-current-record "ext:bbdb-com" (&optional planning-on-modifying)) (declare-function bbdb-name "ext:bbdb-com" (string elidep)) -(declare-function bbdb-completing-read-record "ext:bbdb-com" - (prompt &optional omit-records)) +(declare-function bbdb-completing-read-record "ext:bbdb-com" (prompt &optional omit-records)) (declare-function bbdb-record-field "ext:bbdb" (record field)) (declare-function bbdb-record-getprop "ext:bbdb" (record property)) (declare-function bbdb-record-name "ext:bbdb" (record)) -(declare-function bbdb-records "ext:bbdb" - (&optional dont-check-disk already-in-db-buffer)) +(declare-function bbdb-records "ext:bbdb" (&optional dont-check-disk already-in-db-buffer)) (declare-function bbdb-split "ext:bbdb" (string separators)) (declare-function bbdb-string-trim "ext:bbdb" (string)) (declare-function bbdb-record-get-field "ext:bbdb" (record field)) @@ -121,10 +120,13 @@ ;; `bbdb-record-xfield' replaces it in recent BBDB v3.x+ (declare-function bbdb-record-xfield "ext:bbdb" (record label)) +(declare-function calendar-absolute-from-gregorian "calendar" (date)) +(declare-function calendar-gregorian-from-absolute "calendar" (date)) (declare-function calendar-leap-year-p "calendar" (year)) + (declare-function diary-ordinal-suffix "diary-lib" (n)) -(with-no-warnings (defvar date)) ;; unprefixed, from calendar.el +(with-no-warnings (defvar date)) ;unprefixed, from calendar.el ;; Customization @@ -160,13 +162,13 @@ used." '(("birthday" . (lambda (name years suffix) (concat "Birthday: [[bbdb:" name "][" name " (" - (format "%s" years) ; handles numbers as well as strings - suffix ")]]"))) + (format "%s" years) ; handles numbers as well as strings + suffix ")]]"))) ("wedding" . (lambda (name years suffix) (concat "[[bbdb:" name "][" name "'s " - (format "%s" years) - suffix " wedding anniversary]]")))) + (format "%s" years) + suffix " wedding anniversary]]")))) "How different types of anniversaries should be formatted. An alist of elements (STRING . FORMAT) where STRING is the name of an anniversary class and format is either: @@ -230,7 +232,7 @@ date year)." (bbdb-record-getprop rec 'company) (car (bbdb-record-field rec 'organization)))) (link (concat "bbdb:" name))) - (org-store-link-props :type "bbdb" :name name :company company + (org-link-store-props :type "bbdb" :name name :company company :link link :description name) link))) @@ -300,7 +302,7 @@ italicized, in all other cases it is left unchanged." Argument TIME-STR is the value retrieved from BBDB. If YYYY- is omitted it will be considered unknown." (pcase (org-split-string time-str "-") - (`(,a ,b nil) (list (string-to-number a) (string-to-number b) nil)) + (`(,a ,b) (list (string-to-number a) (string-to-number b) nil)) (`(,a ,b ,c) (list (string-to-number b) (string-to-number c) (string-to-number a))))) @@ -532,10 +534,10 @@ END:VEVENT\n" (concat (capitalize categ) " " (nth 1 rec)) categ))))) -(provide 'org-bbdb) +(provide 'ol-bbdb) ;; Local variables: ;; generated-autoload-file: "org-loaddefs.el" ;; End: -;;; org-bbdb.el ends here +;;; ol-bbdb.el ends here diff --git a/lisp/org/org-bibtex.el b/lisp/org/ol-bibtex.el index 218112cbd5a..78cdd046c94 100644 --- a/lisp/org/org-bibtex.el +++ b/lisp/org/ol-bibtex.el @@ -1,4 +1,4 @@ -;;; org-bibtex.el --- Org links to BibTeX entries -*- lexical-binding: t; -*- +;;; ol-bibtex.el --- Links to BibTeX entries -*- lexical-binding: t; -*- ;; ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. ;; @@ -107,21 +107,37 @@ ;;; Code: -(require 'org) (require 'bibtex) (require 'cl-lib) (require 'org-compat) +(require 'org-macs) +(require 'ol) (defvar org-agenda-overriding-header) (defvar org-agenda-search-view-always-boolean) (defvar org-bibtex-description nil) ; dynamically scoped from org.el (defvar org-id-locations) +(defvar org-property-end-re) +(defvar org-special-properties) +(defvar org-window-config-before-follow-link) (declare-function bibtex-beginning-of-entry "bibtex" ()) (declare-function bibtex-generate-autokey "bibtex" ()) (declare-function bibtex-parse-entry "bibtex" (&optional content)) (declare-function bibtex-url "bibtex" (&optional pos no-browse)) +(declare-function org-back-to-heading "org" (&optional invisible-ok)) +(declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) +(declare-function org-entry-properties "org" (&optional pom which)) +(declare-function org-get-tags "org" (&optional pos local)) +(declare-function org-heading-components "org" ()) +(declare-function org-insert-heading "org" (&optional arg invisible-ok top)) +(declare-function org-map-entries "org" (func &optional match scope &rest skip)) +(declare-function org-narrow-to-subtree "org" ()) +(declare-function org-open-file "org" (path &optional in-emacs line search)) +(declare-function org-set-property "org" (property value)) +(declare-function org-toggle-tag "org" (tag &optional onoff)) + ;;; Bibtex data (defvar org-bibtex-types @@ -354,9 +370,8 @@ and `org-exclude-tags-from-inheritance'." (append org-bibtex-tags org-bibtex-no-export-tags)) tag)) - (if org-bibtex-inherit-tags - (org-get-tags-at) - (org-get-local-tags-at))))))) + (if org-bibtex-inherit-tags (org-get-tags) + (org-get-tags nil t))))))) (when type (let ((entry (format "@%s{%s,\n%s\n}\n" type id @@ -489,7 +504,7 @@ With optional argument OPTIONAL, also prompt for optional fields." (save-excursion (bibtex-beginning-of-entry) (bibtex-parse-entry))))) - (org-store-link-props + (org-link-store-props :key (cdr (assoc "=key=" entry)) :author (or (cdr (assoc "author" entry)) "[no author]") :editor (or (cdr (assoc "editor" entry)) "[no editor]") @@ -743,6 +758,6 @@ This function relies `org-search-view' to locate results." string (or org-bibtex-prefix "") org-bibtex-type-property-name)))) -(provide 'org-bibtex) +(provide 'ol-bibtex) -;;; org-bibtex.el ends here +;;; ol-bibtex.el ends here diff --git a/lisp/org/org-docview.el b/lisp/org/ol-docview.el index 7e1287f9270..0aadb9a5487 100644 --- a/lisp/org/org-docview.el +++ b/lisp/org/ol-docview.el @@ -1,4 +1,4 @@ -;;; org-docview.el --- Support for links to doc-view-mode buffers -*- lexical-binding: t; -*- +;;; ol-docview.el --- Links to Docview mode buffers -*- lexical-binding: t; -*- ;; Copyright (C) 2009-2019 Free Software Foundation, Inc. @@ -43,11 +43,12 @@ ;;; Code: -(require 'org) (require 'doc-view) +(require 'ol) (declare-function doc-view-goto-page "doc-view" (page)) (declare-function image-mode-window-get "image-mode" (prop &optional winprops)) +(declare-function org-open-file "org" (path &optional in-emacs line search)) (org-link-set-parameters "docview" :follow #'org-docview-open @@ -56,11 +57,11 @@ (defun org-docview-export (link description format) "Export a docview link from Org files." - (let* ((path (if (string-match "\\(.+\\)::.+" link) (match-string 1 link) - link)) - (desc (or description link))) + (let ((path (if (string-match "\\(.+\\)::.+" link) (match-string 1 link) + link)) + (desc (or description link))) (when (stringp path) - (setq path (org-link-escape (expand-file-name path))) + (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)) @@ -84,7 +85,7 @@ (let* ((path buffer-file-name) (page (image-mode-window-get 'page)) (link (concat "docview:" path "::" (number-to-string page)))) - (org-store-link-props + (org-link-store-props :type "docview" :link link :description path)))) @@ -93,11 +94,11 @@ "Use the existing file name completion for file. Links to get the file name, then ask the user for the page number and append it." - (concat (replace-regexp-in-string "^file:" "docview:" (org-file-complete-link)) + (concat (replace-regexp-in-string "^file:" "docview:" (org-link-complete-file)) "::" (read-from-minibuffer "Page:" "1"))) -(provide 'org-docview) +(provide 'ol-docview) -;;; org-docview.el ends here +;;; ol-docview.el ends here diff --git a/lisp/org/org-eshell.el b/lisp/org/ol-eshell.el index 2251a1b892f..137e30f2317 100644 --- a/lisp/org/org-eshell.el +++ b/lisp/org/ol-eshell.el @@ -1,4 +1,4 @@ -;;; org-eshell.el - Support for Links to Working Directories in Eshell -*- lexical-binding: t; -*- +;;; ol-eshell.el - Links to Working Directories in Eshell -*- lexical-binding: t; -*- ;; Copyright (C) 2011-2019 Free Software Foundation, Inc. @@ -23,16 +23,18 @@ ;;; Code: -(require 'org) (require 'eshell) (require 'esh-mode) +(require 'ol) + +(declare-function eshell/pwd "em-dirs.el" (&rest args)) (org-link-set-parameters "eshell" :follow #'org-eshell-open :store #'org-eshell-store-link) (defun org-eshell-open (link) - "Switch to am eshell buffer and execute a command line. + "Switch to an eshell buffer and execute a command line. 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." @@ -55,12 +57,12 @@ "Store a link that, when opened, switches back to the current eshell buffer and the current working directory." (when (eq major-mode 'eshell-mode) - (let* ((command (concat "cd " dired-directory)) + (let* ((command (concat "cd " (eshell/pwd))) (link (concat (buffer-name) ":" command))) - (org-store-link-props + (org-link-store-props :link (concat "eshell:" link) :description command)))) -(provide 'org-eshell) +(provide 'ol-eshell) -;;; org-eshell.el ends here +;;; ol-eshell.el ends here diff --git a/lisp/org/org-eww.el b/lisp/org/ol-eww.el index 49882372649..96357c4e6f5 100644 --- a/lisp/org/org-eww.el +++ b/lisp/org/ol-eww.el @@ -1,4 +1,4 @@ -;;; org-eww.el --- Store url and kill from Eww mode for Org -*- lexical-binding: t -*- +;;; ol-eww.el --- Store URL and kill from Eww mode -*- lexical-binding: t -*- ;; Copyright (C) 2014-2019 Free Software Foundation, Inc. @@ -44,7 +44,7 @@ ;;; Code: -(require 'org) +(require 'ol) (require 'cl-lib) (defvar eww-current-title) @@ -55,12 +55,12 @@ (declare-function eww-current-url "eww") -;; Store Org-link in eww-mode buffer +;; Store Org link in Eww mode buffer (org-link-set-parameters "eww" :follow #'eww :store #'org-eww-store-link) (defun org-eww-store-link () "Store a link to the url of an EWW buffer." (when (eq major-mode 'eww-mode) - (org-store-link-props + (org-link-store-props :type "eww" :link (if (< emacs-major-version 25) eww-current-url @@ -72,7 +72,7 @@ (eww-current-url)))))) -;; Some auxiliary functions concerning links in eww buffers +;; Some auxiliary functions concerning links in Eww buffers (defun org-eww-goto-next-url-property-change () "Move to the start of next link if exists. Otherwise point is not moved. Return point." @@ -93,11 +93,12 @@ Otherwise point is not moved. Return point." (defun org-eww-copy-for-org-mode () "Copy current buffer content or active region with `org-mode' style links. This will encode `link-title' and `link-location' with -`org-make-link-string', and insert the transformed test into the kill ring, -so that it can be yanked into an Org mode buffer with links working correctly. +`org-link-make-string' and insert the transformed text into the +kill ring, so that it can be yanked into an Org mode buffer with +links working correctly. -Further lines starting with a star get quoted with a comma to keep -the structure of the Org file." +Further lines starting with a star get quoted with a comma to +keep the structure of the Org file." (interactive) (let* ((regionp (org-region-active-p)) (transform-start (point-min)) @@ -140,13 +141,13 @@ the structure of the Org file." ;; concat `org-mode' style url to `return-content'. (setq return-content (concat return-content - (if (stringp link-location) - ;; hint: link-location is different for form-elements. - (org-make-link-string link-location link-title) + (if (org-string-nw-p link-location) + ;; Hint: link-location is different + ;; for form-elements. + (org-link-make-string link-location link-title) link-title)))) (goto-char temp-position) ; reset point before jump next anchor - (setq out-bound t) ; for break out `while' loop - )) + (setq out-bound t))) ; for break out `while' loop ;; Add the rest until end of the region to be copied. (when (< (point) transform-end) (setq return-content @@ -170,6 +171,6 @@ the structure of the Org file." (add-hook 'eww-mode-hook #'org-eww-extend-eww-keymap) -(provide 'org-eww) +(provide 'ol-eww) -;;; org-eww.el ends here +;;; ol-eww.el ends here diff --git a/lisp/org/org-gnus.el b/lisp/org/ol-gnus.el index 15e95647a09..8ac36f0ed7e 100644 --- a/lisp/org/org-gnus.el +++ b/lisp/org/ol-gnus.el @@ -1,4 +1,4 @@ -;;; org-gnus.el --- Support for Links to Gnus Groups and Messages -*- lexical-binding: t; -*- +;;; ol-gnus.el --- Links to Gnus Groups and Messages -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2019 Free Software Foundation, Inc. @@ -35,7 +35,7 @@ (require 'gnus-util) (require 'nnheader) (require 'nnir) -(require 'org) +(require 'ol) ;;; Declare external functions and variables @@ -104,6 +104,7 @@ If `org-store-link' was called with a prefix arg the meaning of (defun org-gnus-article-link (group newsgroups message-id x-no-archive) "Create a link to a Gnus article. + The article is specified by its MESSAGE-ID. Additional parameters are the Gnus GROUP, the NEWSGROUPS the article was posted to and the X-NO-ARCHIVE header value of that article. @@ -115,12 +116,12 @@ Otherwise create a link to the article inside Gnus. If `org-store-link' was called with a prefix arg the meaning of `org-gnus-prefer-web-links' is reversed." (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links) - newsgroups ;; Make web links only for nntp groups - (not x-no-archive)) ;; and if X-No-Archive isn't set. - (format (if (string-match "gmane\\." newsgroups) + newsgroups ;make web links only for nntp groups + (not x-no-archive)) ;and if X-No-Archive isn't set + (format (if (string-match-p "gmane\\." newsgroups) "http://mid.gmane.org/%s" "http://groups.google.com/groups/search?as_umsgid=%s") - (org-fixup-message-id-for-http message-id)) + (url-encode-url message-id)) (concat "gnus:" group "#" message-id))) (defun org-gnus-store-link () @@ -129,9 +130,9 @@ If `org-store-link' was called with a prefix arg the meaning of (`gnus-group-mode (let ((group (gnus-group-group-name))) (when group - (org-store-link-props :type "gnus" :group group) + (org-link-store-props :type "gnus" :group group) (let ((description (org-gnus-group-link group))) - (org-add-link-props :link description :description description) + (org-link-add-props :link description :description description) description)))) ((or `gnus-summary-mode `gnus-article-mode) (let* ((group @@ -169,12 +170,12 @@ If `org-store-link' was called with a prefix arg the meaning of (setq to (or to (gnus-fetch-original-field "To"))) (setq newsgroups (gnus-fetch-original-field "Newsgroups")) (setq x-no-archive (gnus-fetch-original-field "x-no-archive"))) - (org-store-link-props :type "gnus" :from from :date date :subject subject + (org-link-store-props :type "gnus" :from from :date date :subject subject :message-id message-id :group group :to to) (let ((link (org-gnus-article-link group newsgroups message-id x-no-archive)) - (description (org-email-link-description))) - (org-add-link-props :link link :description description) + (description (org-link-email-description))) + (org-link-add-props :link link :description description) link))) (`message-mode (setq org-store-link-plist nil) ;reset @@ -197,11 +198,11 @@ If `org-store-link' was called with a prefix arg the meaning of (subject (mail-fetch-field "Subject")) newsgroup xarchive) ;those are always nil for gcc (unless gcc (error "Can not create link: No Gcc header found")) - (org-store-link-props :type "gnus" :from from :subject subject + (org-link-store-props :type "gnus" :from from :subject subject :message-id id :group gcc :to to) (let ((link (org-gnus-article-link gcc newsgroup id xarchive)) - (description (org-email-link-description))) - (org-add-link-props :link link :description description) + (description (org-link-email-description))) + (org-link-add-props :link link :description description) link))))))) (defun org-gnus-open-nntp (path) @@ -242,7 +243,11 @@ If `org-store-link' was called with a prefix arg the meaning of (_ (let ((articles 1) group-opened) - (while (not group-opened) + (while (and (not group-opened) + ;; Stop on integer overflows. Note: We + ;; can drop this once we require at least + ;; Emacs 27, which supports bignums. + (> articles 0)) (setq group-opened (gnus-group-read-group articles t group)) (setq articles (if (< articles 16) (1+ articles) @@ -260,7 +265,6 @@ If `org-store-link' was called with a prefix arg the meaning of (org-gnus-no-server (gnus-no-server)) (t (gnus)))) -(provide 'org-gnus) - +(provide 'ol-gnus) -;;; org-gnus.el ends here +;;; ol-gnus.el ends here diff --git a/lisp/org/org-info.el b/lisp/org/ol-info.el index bfbe42cb053..d145eae72d6 100644 --- a/lisp/org/org-info.el +++ b/lisp/org/ol-info.el @@ -1,4 +1,4 @@ -;;; org-info.el --- Support for Links to Info Nodes -*- lexical-binding: t; -*- +;;; ol-info.el --- Links to Info Nodes -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2019 Free Software Foundation, Inc. @@ -30,7 +30,7 @@ ;;; Code: -(require 'org) +(require 'ol) ;; Declare external functions and variables @@ -54,7 +54,7 @@ "#" Info-current-node)) (desc (concat (file-name-nondirectory Info-current-file) "#" Info-current-node))) - (org-store-link-props :type "info" :file Info-current-file + (org-link-store-props :type "info" :file Info-current-file :node Info-current-node :link link :desc desc) link))) @@ -66,7 +66,7 @@ (defun org-info-follow-link (name) "Follow an Info file and node link specified by NAME." - (if (or (string-match "\\(.*\\)[#:]:?\\(.*\\)" name) + (if (or (string-match "\\(.*\\)\\(?:#\\|::\\)\\(.*\\)" name) (string-match "\\(.*\\)" name)) (let ((filename (match-string 1 name)) (nodename-or-index (or (match-string 2 name) "Top"))) @@ -129,7 +129,7 @@ See `org-info-emacs-documents' and `org-info-other-documents' for details." (defun org-info-export (path desc format) "Export an info link. See `org-link-parameters' for details about PATH, DESC and FORMAT." - (let* ((parts (split-string path "[#:]:?")) + (let* ((parts (split-string path "#\\|::")) (manual (car parts)) (node (or (nth 1 parts) "Top"))) (pcase format @@ -143,6 +143,6 @@ See `org-link-parameters' for details about PATH, DESC and FORMAT." (format "@ref{%s,%s,,%s,}" node title manual))) (_ nil)))) -(provide 'org-info) +(provide 'ol-info) -;;; org-info.el ends here +;;; ol-info.el ends here diff --git a/lisp/org/org-irc.el b/lisp/org/ol-irc.el index 97f093e5b7c..d39760b75f5 100644 --- a/lisp/org/org-irc.el +++ b/lisp/org/ol-irc.el @@ -1,4 +1,4 @@ -;;; org-irc.el --- Store Links to IRC Sessions -*- lexical-binding: t; -*- +;;; ol-irc.el --- Links to IRC Sessions -*- lexical-binding: t; -*- ;; ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. ;; @@ -48,7 +48,7 @@ ;;; Code: -(require 'org) +(require 'ol) (declare-function erc-buffer-filter "erc" (predicate &optional proc)) (declare-function erc-channel-p "erc" (channel)) @@ -73,7 +73,10 @@ ;; Generic functions/config (extend these for other clients) -(org-link-set-parameters "irc" :follow #'org-irc-visit :store #'org-irc-store-link) +(org-link-set-parameters "irc" + :follow #'org-irc-visit + :store #'org-irc-store-link + :export #'org-irc-export) (defun org-irc-visit (link) "Parse LINK and dispatch to the correct function based on the client found." @@ -152,7 +155,7 @@ the session itself." (parsed-line (org-irc-erc-get-line-from-log erc-line))) (if (erc-logging-enabled nil) (progn - (org-store-link-props + (org-link-store-props :type "file" :description (concat "'" (org-irc-ellipsify-description (cadr parsed-line) 20) @@ -165,7 +168,7 @@ the session itself." (link (org-irc-parse-link link-text))) (if link-text (progn - (org-store-link-props + (org-link-store-props :type "irc" :link (concat "irc:/" link-text) :description (concat "irc session `" link-text "'") @@ -247,10 +250,20 @@ default." ;; no server match, make new connection (erc-select :server server :port port)))) -(provide 'org-irc) +(defun org-irc-export (link description format) + "Export an IRC link. +See `org-link-parameters' for details about LINK, DESCRIPTION and +FORMAT." + (let ((desc (or description link))) + (pcase format + (`html (format "<a href=\"irc:%s\">%s</a>" link desc)) + (`md (format "[%s](irc:%s)" desc link)) + (_ nil)))) + +(provide 'ol-irc) ;; Local variables: ;; generated-autoload-file: "org-loaddefs.el" ;; End: -;;; org-irc.el ends here +;;; ol-irc.el ends here diff --git a/lisp/org/org-mhe.el b/lisp/org/ol-mhe.el index a37c41ad06e..b2c163c9350 100644 --- a/lisp/org/org-mhe.el +++ b/lisp/org/ol-mhe.el @@ -1,4 +1,4 @@ -;;; org-mhe.el --- Support for Links to MH-E Messages -*- lexical-binding: t; -*- +;;; ol-mhe.el --- Links to MH-E Messages -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2019 Free Software Foundation, Inc. @@ -31,7 +31,7 @@ ;;; Code: (require 'org-macs) -(require 'org) +(require 'ol) ;; Customization variables @@ -88,12 +88,12 @@ supported by MH-E." (subject (org-mhe-get-header "Subject:")) (date (org-mhe-get-header "Date:")) link desc) - (org-store-link-props :type "mh" :from from :to to :date date + (org-link-store-props :type "mh" :from from :to to :date date :subject subject :message-id message-id) - (setq desc (org-email-link-description)) + (setq desc (org-link-email-description)) (setq link (concat "mhe:" (org-mhe-get-message-real-folder) "#" (org-unbracket-string "<" ">" message-id))) - (org-add-link-props :link link :description desc) + (org-link-add-props :link link :description desc) link)))) (defun org-mhe-open (path) @@ -199,7 +199,7 @@ folders." (mh-search-choose) (if (eq mh-searcher 'pick) (progn - (setq article (org-add-angle-brackets article)) + (setq article (org-link-add-angle-brackets article)) (mh-search folder (list "--message-id" article)) (when (and org-mhe-search-all-folders (not (org-mhe-get-message-real-folder))) @@ -214,6 +214,6 @@ folders." (kill-buffer) (error "Message not found")))) -(provide 'org-mhe) +(provide 'ol-mhe) -;;; org-mhe.el ends here +;;; ol-mhe.el ends here diff --git a/lisp/org/org-rmail.el b/lisp/org/ol-rmail.el index c3d941e65d0..a62b917d178 100644 --- a/lisp/org/org-rmail.el +++ b/lisp/org/ol-rmail.el @@ -1,4 +1,4 @@ -;;; org-rmail.el --- Support for Links to Rmail Messages -*- lexical-binding: t; -*- +;;; ol-rmail.el --- Links to Rmail Messages -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2019 Free Software Foundation, Inc. @@ -30,7 +30,7 @@ ;;; Code: -(require 'org) +(require 'ol) ;; Declare external functions and variables (declare-function rmail-show-message "rmail" (&optional n no-summary)) @@ -65,13 +65,13 @@ (subject (mail-fetch-field "subject")) (date (mail-fetch-field "date")) desc link) - (org-store-link-props + (org-link-store-props :type "rmail" :from from :to to :date date :subject subject :message-id message-id) (setq message-id (org-unbracket-string "<" ">" message-id)) - (setq desc (org-email-link-description)) + (setq desc (org-link-email-description)) (setq link (concat "rmail:" folder "#" message-id)) - (org-add-link-props :link link :description desc) + (org-link-add-props :link link :description desc) (rmail-show-message rmail-current-message) link))))) @@ -89,7 +89,7 @@ (require 'rmail) (cond ((null article) (setq article "")) ((stringp article) - (setq article (org-add-angle-brackets article))) + (setq article (org-link-add-angle-brackets article))) (t (user-error "Wrong RMAIL link format"))) (let (message-number) (save-excursion @@ -110,6 +110,6 @@ message-number) (error "Message not found")))) -(provide 'org-rmail) +(provide 'ol-rmail) -;;; org-rmail.el ends here +;;; ol-rmail.el ends here diff --git a/lisp/org/org-w3m.el b/lisp/org/ol-w3m.el index 23fd0f82e65..046d3b6b6d3 100644 --- a/lisp/org/org-w3m.el +++ b/lisp/org/ol-w3m.el @@ -1,4 +1,4 @@ -;;; org-w3m.el --- Support from Copy and Paste From w3m -*- lexical-binding: t; -*- +;;; ol-w3m.el --- Copy and Paste From W3M -*- lexical-binding: t; -*- ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. @@ -41,7 +41,7 @@ ;;; Code: -(require 'org) +(require 'ol) (defvar w3m-current-url) (defvar w3m-current-title) @@ -50,7 +50,7 @@ (defun org-w3m-store-link () "Store a link to a w3m buffer." (when (eq major-mode 'w3m-mode) - (org-store-link-props + (org-link-store-props :type "w3m" :link w3m-current-url :url (url-view-url t) @@ -59,7 +59,7 @@ (defun org-w3m-copy-for-org-mode () "Copy current buffer content or active region with Org style links. This will encode `link-title' and `link-location' with -`org-make-link-string', and insert the transformed test into the kill ring, +`org-link-make-string', and insert the transformed test into the kill ring, so that it can be yanked into an Org buffer with links working correctly." (interactive) (let* ((regionp (org-region-active-p)) @@ -72,40 +72,41 @@ so that it can be yanked into an Org buffer with links working correctly." (setq transform-start (region-beginning)) (setq transform-end (region-end)) ;; Deactivate mark if current mark is activate. - (if (fboundp 'deactivate-mark) (deactivate-mark))) + (when (fboundp 'deactivate-mark) (deactivate-mark))) (message "Transforming links...") (save-excursion (goto-char transform-start) - (while (and (not out-bound) ; still inside region to copy + (while (and (not out-bound) ; still inside region to copy (not (org-w3m-no-next-link-p))) ; no next link current buffer ;; store current point before jump next anchor (setq temp-position (point)) ;; move to next anchor when current point is not at anchor (or (get-text-property (point) 'w3m-href-anchor) (org-w3m-get-next-link-start)) - (if (<= (point) transform-end) ; if point is inside transform bound + (if (<= (point) transform-end) ; if point is inside transform bound (progn ;; get content between two links. - (if (> (point) temp-position) - (setq return-content (concat return-content - (buffer-substring - temp-position (point))))) + (when (> (point) temp-position) + (setq return-content (concat return-content + (buffer-substring + temp-position (point))))) ;; get link location at current point. (setq link-location (get-text-property (point) 'w3m-href-anchor)) ;; get link title at current point. (setq link-title (buffer-substring (point) (org-w3m-get-anchor-end))) ;; concat Org style url to `return-content'. - (setq return-content (concat return-content - (org-make-link-string - link-location link-title)))) - (goto-char temp-position) ; reset point before jump next anchor - (setq out-bound t) ; for break out `while' loop - )) + (setq return-content + (concat return-content + (if (org-string-nw-p link-location) + (org-link-make-string link-location link-title) + link-title)))) + (goto-char temp-position) ; reset point before jump next anchor + (setq out-bound t))) ; for break out `while' loop ;; add the rest until end of the region to be copied - (if (< (point) transform-end) - (setq return-content - (concat return-content - (buffer-substring (point) transform-end)))) + (when (< (point) transform-end) + (setq return-content + (concat return-content + (buffer-substring (point) transform-end)))) (org-kill-new return-content) (message "Transforming links...done, use C-y to insert text into Org file") (message "Copy with link transformation complete.")))) @@ -178,6 +179,6 @@ Return t if there is no previous link; otherwise, return nil." (define-key w3m-minor-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) (define-key w3m-minor-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode))) -(provide 'org-w3m) +(provide 'ol-w3m) -;;; org-w3m.el ends here +;;; ol-w3m.el ends here diff --git a/lisp/org/ol.el b/lisp/org/ol.el new file mode 100644 index 00000000000..95a7e916e9c --- /dev/null +++ b/lisp/org/ol.el @@ -0,0 +1,1907 @@ +;;; ol.el --- Org links library -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library provides tooling to handle both external and internal +;; links. + +;;; Code: + +(require 'org-compat) +(require 'org-macs) + +(defvar clean-buffer-list-kill-buffer-names) +(defvar org-agenda-buffer-name) +(defvar org-comment-string) +(defvar org-highlight-links) +(defvar org-id-link-to-org-use-id) +(defvar org-inhibit-startup) +(defvar org-outline-regexp-bol) +(defvar org-src-source-file-name) +(defvar org-time-stamp-formats) +(defvar org-ts-regexp) + +(declare-function calendar-cursor-to-date "calendar" (&optional error event)) +(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) +(declare-function org-at-heading-p "org" (&optional _)) +(declare-function org-back-to-heading "org" (&optional invisible-ok)) +(declare-function org-do-occur "org" (regexp &optional cleanup)) +(declare-function org-element-at-point "org-element" ()) +(declare-function org-element-cache-refresh "org-element" (pos)) +(declare-function org-element-context "org-element" (&optional element)) +(declare-function org-element-lineage "org-element" (datum &optional types with-self)) +(declare-function org-element-link-parser "org-element" ()) +(declare-function org-element-property "org-element" (property element)) +(declare-function org-element-type "org-element" (element)) +(declare-function org-element-update-syntax "org-element" ()) +(declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) +(declare-function org-find-property "org" (property &optional value)) +(declare-function org-get-heading "org" (&optional no-tags no-todo no-priority no-comment)) +(declare-function org-heading-components "org" ()) +(declare-function org-id-find-id-file "org-id" (id)) +(declare-function org-id-store-link "org-id" ()) +(declare-function org-insert-heading "org" (&optional arg invisible-ok top)) +(declare-function org-load-modules-maybe "org" (&optional force)) +(declare-function org-mark-ring-push "org" (&optional pos buffer)) +(declare-function org-occur "org" (regexp &optional keep-previous callback)) +(declare-function org-open-file "org" (path &optional in-emacs line search)) +(declare-function org-overview "org" ()) +(declare-function org-restart-font-lock "org" ()) +(declare-function org-show-context "org" (&optional key)) +(declare-function org-src-coderef-format "org-src" (&optional element)) +(declare-function org-src-coderef-regexp "org-src" (fmt &optional label)) +(declare-function org-src-edit-buffer-p "org-src" (&optional buffer)) +(declare-function org-src-source-buffer "org-src" ()) +(declare-function org-src-source-type "org-src" ()) +(declare-function org-time-stamp-format "org" (&optional long inactive)) +(declare-function outline-next-heading "outline" ()) + + +;;; Customization + +(defgroup org-link nil + "Options concerning links in Org mode." + :tag "Org Link" + :group 'org) + +(defcustom org-link-parameters nil + "An alist of properties that defines all the links in Org mode. +The key in each association is a string of the link type. +Subsequent optional elements make up a plist of link properties. + +:follow - A function that takes the link path as an argument. + +:export - A function that takes the link path, description and +export-backend as arguments. + +:store - A function responsible for storing the link. See the +function `org-store-link-functions'. + +:complete - A function that inserts a link with completion. The +function takes one optional prefix argument. + +:face - A face for the link, or a function that returns a face. +The function takes one argument which is the link path. The +default face is `org-link'. + +:mouse-face - The mouse-face. The default is `highlight'. + +:display - `full' will not fold the link in descriptive +display. Default is `org-link'. + +:help-echo - A string or function that takes (window object position) +as arguments and returns a string. + +:keymap - A keymap that is active on the link. The default is +`org-mouse-map'. + +:htmlize-link - A function for the htmlize-link. Defaults +to (list :uri \"type:path\") + +:activate-func - A function to run at the end of font-lock +activation. The function must accept (link-start link-end path bracketp) +as arguments." + :group 'org-link + :package-version '(Org . "9.1") + :type '(alist :tag "Link display parameters" + :value-type plist) + :safe nil) + +(defcustom org-link-descriptive t + "Non-nil means Org displays descriptive links. + +E.g. [[https://orgmode.org][Org website]] is be displayed as +\"Org Website\", hiding the link itself and just displaying its +description. When set to nil, Org displays the full links +literally. + +You can interactively set the value of this variable by calling +`org-toggle-link-display' or from the \"Org > Hyperlinks\" menu." + :group 'org-link + :type 'boolean + :safe #'booleanp) + +(defcustom org-link-make-description-function nil + "Function to use for generating link descriptions from links. +This function must take two parameters: the first one is the +link, the second one is the description generated by +`org-insert-link'. The function should return the description to +use." + :group 'org-link + :type '(choice (const nil) (function)) + :safe #'null) + +(defcustom org-link-file-path-type 'adaptive + "How the path name in file links should be stored. +Valid values are: + +relative Relative to the current directory, i.e. the directory of the file + into which the link is being inserted. +absolute Absolute path, if possible with ~ for home directory. +noabbrev Absolute path, no abbreviation of home directory. +adaptive Use relative path for files in the current directory and sub- + directories of it. For other files, use an absolute path." + :group 'org-link + :type '(choice + (const relative) + (const absolute) + (const noabbrev) + (const adaptive)) + :safe #'symbolp) + +(defcustom org-link-abbrev-alist nil + "Alist of link abbreviations. +The car of each element is a string, to be replaced at the start of a link. +The cdrs are replacement values, like (\"linkkey\" . REPLACE). Abbreviated +links in Org buffers can have an optional tag after a double colon, e.g., + + [[linkkey:tag][description]] + +The `linkkey' must be a single word, starting with a letter, followed +by letters, numbers, `-' or `_'. + +If REPLACE is a string, the tag will simply be appended to create the link. +If the string contains \"%s\", the tag will be inserted there. If the string +contains \"%h\", it will cause a url-encoded version of the tag to be inserted +at that point (see the function `url-hexify-string'). If the string contains +the specifier \"%(my-function)\", then the custom function `my-function' will +be invoked: this function takes the tag as its only argument and must return +a string. + +REPLACE may also be a function that will be called with the tag as the +only argument to create the link, which should be returned as a string. + +See the manual for examples." + :group 'org-link + :type '(repeat + (cons (string :tag "Protocol") + (choice + (string :tag "Format") + (function)))) + :safe (lambda (val) + (pcase val + (`(,(pred stringp) . ,(pred stringp)) t) + (_ nil)))) + +(defgroup org-link-follow nil + "Options concerning following links in Org mode." + :tag "Org Follow Link" + :group 'org-link) + +(defcustom org-link-translation-function nil + "Function to translate links with different syntax to Org syntax. +This can be used to translate links created for example by the Planner +or emacs-wiki packages to Org syntax. +The function must accept two parameters, a TYPE containing the link +protocol name like \"rmail\" or \"gnus\" as a string, and the linked path, +which is everything after the link protocol. It should return a cons +with possibly modified values of type and path. +Org contains a function for this, so if you set this variable to +`org-translate-link-from-planner', you should be able follow many +links created by planner." + :group 'org-link-follow + :type '(choice (const nil) (function)) + :safe #'null) + +(defcustom org-link-doi-server-url "https://doi.org/" + "The URL of the DOI server." + :group 'org-link-follow + :version "24.3" + :type 'string + :safe #'stringp) + +(defcustom org-link-frame-setup + '((vm . vm-visit-folder-other-frame) + (vm-imap . vm-visit-imap-folder-other-frame) + (gnus . org-gnus-no-new-news) + (file . find-file-other-window) + (wl . wl-other-frame)) + "Setup the frame configuration for following links. +When following a link with Emacs, it may often be useful to display +this link in another window or frame. This variable can be used to +set this up for the different types of links. +For VM, use any of + `vm-visit-folder' + `vm-visit-folder-other-window' + `vm-visit-folder-other-frame' +For Gnus, use any of + `gnus' + `gnus-other-frame' + `org-gnus-no-new-news' +For FILE, use any of + `find-file' + `find-file-other-window' + `find-file-other-frame' +For Wanderlust use any of + `wl' + `wl-other-frame' +For the calendar, use the variable `calendar-setup'. +For BBDB, it is currently only possible to display the matches in +another window." + :group 'org-link-follow + :type '(list + (cons (const vm) + (choice + (const vm-visit-folder) + (const vm-visit-folder-other-window) + (const vm-visit-folder-other-frame))) + (cons (const vm-imap) + (choice + (const vm-visit-imap-folder) + (const vm-visit-imap-folder-other-window) + (const vm-visit-imap-folder-other-frame))) + (cons (const gnus) + (choice + (const gnus) + (const gnus-other-frame) + (const org-gnus-no-new-news))) + (cons (const file) + (choice + (const find-file) + (const find-file-other-window) + (const find-file-other-frame))) + (cons (const wl) + (choice + (const wl) + (const wl-other-frame)))) + :safe nil) + +(defcustom org-link-search-must-match-exact-headline 'query-to-create + "Non-nil means internal fuzzy links can only match headlines. + +When nil, the a fuzzy link may point to a target or a named +construct in the document. When set to the special value +`query-to-create', offer to create a new headline when none +matched. + +Spaces and statistics cookies are ignored during heading searches." + :group 'org-link-follow + :version "24.1" + :type '(choice + (const :tag "Use fuzzy text search" nil) + (const :tag "Match only exact headline" t) + (const :tag "Match exact headline or query to create it" + query-to-create)) + :safe #'symbolp) + +(defcustom org-link-use-indirect-buffer-for-internals nil + "Non-nil means use indirect buffer to display infile links. +Activating internal links (from one location in a file to another location +in the same file) normally just jumps to the location. When the link is +activated with a `\\[universal-argument]' prefix (or with mouse-3), the link \ +is displayed in +another window. When this option is set, the other window actually displays +an indirect buffer clone of the current buffer, to avoid any visibility +changes to the current buffer." + :group 'org-link-follow + :type 'boolean + :safe #'booleanp) + +(defcustom org-link-shell-confirm-function 'yes-or-no-p + "Non-nil means ask for confirmation before executing shell links. + +Shell links can be dangerous: just think about a link + + [[shell:rm -rf ~/*][Google Search]] + +This link would show up in your Org document as \"Google Search\", +but really it would remove your entire home directory. +Therefore we advise against setting this variable to nil. +Just change it to `y-or-n-p' if you want to confirm with a +single keystroke rather than having to type \"yes\"." + :group 'org-link-follow + :type '(choice + (const :tag "with yes-or-no (safer)" yes-or-no-p) + (const :tag "with y-or-n (faster)" y-or-n-p) + (const :tag "no confirmation (dangerous)" nil)) + :safe nil) + +(defcustom org-link-shell-skip-confirm-regexp "" + "Regexp to skip confirmation for shell links." + :group 'org-link-follow + :version "24.1" + :type 'regexp + :safe nil) + +(defcustom org-link-elisp-confirm-function 'yes-or-no-p + "Non-nil means ask for confirmation before executing Emacs Lisp links. +Elisp links can be dangerous: just think about a link + + [[elisp:(shell-command \"rm -rf ~/*\")][Google Search]] + +This link would show up in your Org document as \"Google Search\", +but really it would remove your entire home directory. +Therefore we advise against setting this variable to nil. +Just change it to `y-or-n-p' if you want to confirm with a +single keystroke rather than having to type \"yes\"." + :group 'org-link-follow + :type '(choice + (const :tag "with yes-or-no (safer)" yes-or-no-p) + (const :tag "with y-or-n (faster)" y-or-n-p) + (const :tag "no confirmation (dangerous)" nil)) + :safe nil) + +(defcustom org-link-elisp-skip-confirm-regexp "" + "A regexp to skip confirmation for Elisp links." + :group 'org-link-follow + :version "24.1" + :type 'regexp + :safe nil) + +(defgroup org-link-store nil + "Options concerning storing links in Org mode." + :tag "Org Store Link" + :group 'org-link) + +(defcustom org-link-context-for-files t + "Non-nil means file links from `org-store-link' contain context. +\\<org-mode-map> +A search string is added to the file name with \"::\" as separator +and used to find the context when the link is activated by the command +`org-open-at-point'. When this option is t, the entire active region +is be placed in the search string of the file link. If set to a +positive integer N, only the first N lines of context are stored. + +Using a prefix argument to the command `org-store-link' \ +\(`\\[universal-argument] \\[org-store-link]') +negates this setting for the duration of the command." + :group 'org-link-store + :type '(choice boolean integer) + :safe (lambda (val) (or (booleanp val) (integerp val)))) + +(defcustom org-link-email-description-format "Email %c: %s" + "Format of the description part of a link to an email or usenet message. +The following %-escapes will be replaced by corresponding information: + +%F full \"From\" field +%f name, taken from \"From\" field, address if no name +%T full \"To\" field +%t first name in \"To\" field, address if no name +%c correspondent. Usually \"from NAME\", but if you sent it yourself, it + will be \"to NAME\". See also the variable `org-from-is-user-regexp'. +%s subject +%d date +%m message-id. + +You may use normal field width specification between the % and the letter. +This is for example useful to limit the length of the subject. + +Examples: \"%f on: %.30s\", \"Email from %f\", \"Email %c\"" + :group 'org-link-store + :package-version '(Org . 9.3) + :type 'string + :safe #'stringp) + +(defcustom org-link-from-user-regexp + (let ((mail (and (org-string-nw-p user-mail-address) + (format "\\<%s\\>" (regexp-quote user-mail-address)))) + (name (and (org-string-nw-p user-full-name) + (format "\\<%s\\>" (regexp-quote user-full-name))))) + (if (and mail name) (concat mail "\\|" name) (or mail name))) + "Regexp matched against the \"From:\" header of an email or Usenet message. +It should match if the message is from the user him/herself." + :group 'org-link-store + :type 'regexp + :safe #'stringp) + +(defcustom org-link-keep-stored-after-insertion nil + "Non-nil means keep link in list for entire session. +\\<org-mode-map> +The command `org-store-link' adds a link pointing to the current +location to an internal list. These links accumulate during a session. +The command `org-insert-link' can be used to insert links into any +Org file (offering completion for all stored links). + +When this option is nil, every link which has been inserted once using +`\\[org-insert-link]' will be removed from the list, to make completing the \ +unused +links more efficient." + :group 'org-link-store + :type 'boolean + :safe #'booleanp) + +;;; Public variables + +(defconst org-target-regexp (let ((border "[^<>\n\r \t]")) + (format "<<\\(%s\\|%s[^<>\n\r]*%s\\)>>" + border border border)) + "Regular expression matching a link target.") + +(defconst org-radio-target-regexp (format "<%s>" org-target-regexp) + "Regular expression matching a radio target.") + +(defvar-local org-target-link-regexp nil + "Regular expression matching radio targets in plain text.") + +(defvar org-link-types-re nil + "Matches a link that has a url-like prefix like \"http:\"") + +(defvar org-link-angle-re nil + "Matches link with angular brackets, spaces are allowed.") + +(defvar org-link-plain-re nil + "Matches plain link, without spaces.") + +(defvar org-link-bracket-re nil + "Matches a link in double brackets.") + +(defvar org-link-any-re nil + "Regular expression matching any link.") + +(defvar-local org-link-abbrev-alist-local nil + "Buffer-local version of `org-link-abbrev-alist', which see. +The value of this is taken from the LINK keywords.") + +(defvar org-stored-links nil + "Contains the links stored with `org-store-link'.") + +(defvar org-store-link-plist nil + "Plist with info about the most recently link created with `org-store-link'.") + +(defvar org-create-file-search-functions nil + "List of functions to construct the right search string for a file link. + +These functions are called in turn with point at the location to +which the link should point. + +A function in the hook should first test if it would like to +handle this file type, for example by checking the `major-mode' +or the file extension. If it decides not to handle this file, it +should just return nil to give other functions a chance. If it +does handle the file, it must return the search string to be used +when following the link. The search string will be part of the +file link, given after a double colon, and `org-open-at-point' +will automatically search for it. If special measures must be +taken to make the search successful, another function should be +added to the companion hook `org-execute-file-search-functions', +which see. + +A function in this hook may also use `setq' to set the variable +`description' to provide a suggestion for the descriptive text to +be used for this link when it gets inserted into an Org buffer +with \\[org-insert-link].") + +(defvar org-execute-file-search-functions nil + "List of functions to execute a file search triggered by a link. + +Functions added to this hook must accept a single argument, the +search string that was part of the file link, the part after the +double colon. The function must first check if it would like to +handle this search, for example by checking the `major-mode' or +the file extension. If it decides not to handle this search, it +should just return nil to give other functions a chance. If it +does handle the search, it must return a non-nil value to keep +other functions from trying. + +Each function can access the current prefix argument through the +variable `current-prefix-arg'. Note that a single prefix is used +to force opening a link in Emacs, so it may be good to only use a +numeric or double prefix to guide the search function. + +In case this is needed, a function in this hook can also restore +the window configuration before `org-open-at-point' was called using: + + (set-window-configuration org-window-config-before-follow-link)") + +(defvar org-open-link-functions nil + "Hook for functions finding a plain text link. +These functions must take a single argument, the link content. +They will be called for links that look like [[link text][description]] +when LINK TEXT does not have a protocol like \"http:\" and does not look +like a filename (e.g. \"./blue.png\"). + +These functions will be called *before* Org attempts to resolve the +link by doing text searches in the current buffer - so if you want a +link \"[[target]]\" to still find \"<<target>>\", your function should +handle this as a special case. + +When the function does handle the link, it must return a non-nil value. +If it decides that it is not responsible for this link, it must return +nil to indicate that that Org can continue with other options like +exact and fuzzy text search.") + + +;;; Internal Variables + +(defconst org-link--forbidden-chars "]\t\n\r<>" + "Characters forbidden within a link, as a string.") + +(defvar org-link--history nil + "History for inserted links.") + +(defvar org-link--insert-history nil + "Minibuffer history for links inserted with `org-insert-link'.") + +(defvar org-link--search-failed nil + "Non-nil when last link search failed.") + + +;;; Internal Functions + +(defun org-link--try-special-completion (type) + "If there is completion support for link type TYPE, offer it." + (let ((fun (org-link-get-parameter type :complete))) + (if (functionp fun) + (funcall fun) + (read-string "Link (no completion support): " (concat type ":"))))) + +(defun org-link--prettify (link) + "Return a human-readable representation of LINK. +The car of LINK must be a raw link. The cdr of LINK must be +either a link description or nil." + (let ((desc (or (cadr link) "<no description>"))) + (concat (format "%-45s" (substring desc 0 (min (length desc) 40))) + "<" (car link) ">"))) + +(defun org-link--decode-compound (hex) + "Unhexify Unicode hex-chars HEX. +E.g. \"%C3%B6\" is the German o-Umlaut. Note: this function also +decodes single byte encodings like \"%E1\" (a-acute) if not +followed by another \"%[A-F0-9]{2}\" group." + (save-match-data + (let* ((bytes (cdr (split-string hex "%"))) + (ret "") + (eat 0) + (sum 0)) + (while bytes + (let* ((val (string-to-number (pop bytes) 16)) + (shift-xor + (if (= 0 eat) + (cond + ((>= val 252) (cons 6 252)) + ((>= val 248) (cons 5 248)) + ((>= val 240) (cons 4 240)) + ((>= val 224) (cons 3 224)) + ((>= val 192) (cons 2 192)) + (t (cons 0 0))) + (cons 6 128)))) + (when (>= val 192) (setq eat (car shift-xor))) + (setq val (logxor val (cdr shift-xor))) + (setq sum (+ (lsh sum (car shift-xor)) val)) + (when (> eat 0) (setq eat (- eat 1))) + (cond + ((= 0 eat) ;multi byte + (setq ret (concat ret (char-to-string sum))) + (setq sum 0)) + ((not bytes) ; single byte(s) + (setq ret (org-link--decode-single-byte-sequence hex)))))) + ret))) + +(defun org-link--decode-single-byte-sequence (hex) + "Unhexify hex-encoded single byte character sequence HEX." + (mapconcat (lambda (byte) + (char-to-string (string-to-number byte 16))) + (cdr (split-string hex "%")) + "")) + +(defun org-link--fontify-links-to-this-file () + "Fontify links to the current file in `org-stored-links'." + (let ((f (buffer-file-name)) a b) + (setq a (mapcar (lambda(l) + (let ((ll (car l))) + (when (and (string-match "^file:\\(.+\\)::" ll) + (equal f (expand-file-name (match-string 1 ll)))) + ll))) + org-stored-links)) + (when (featurep 'org-id) + (setq b (mapcar (lambda(l) + (let ((ll (car l))) + (when (and (string-match "^id:\\(.+\\)$" ll) + (equal f (expand-file-name + (or (org-id-find-id-file + (match-string 1 ll)) "")))) + ll))) + org-stored-links))) + (mapcar (lambda(l) + (put-text-property 0 (length l) 'face 'font-lock-comment-face l)) + (delq nil (append a b))))) + +(defun org-link--buffer-for-internals () + "Return buffer used for displaying the target of internal links." + (cond + ((not org-link-use-indirect-buffer-for-internals) (current-buffer)) + ((string-suffix-p "(Clone)" (buffer-name)) + (message "Buffer is already a clone, not making another one") + ;; We also do not modify visibility in this case. + (current-buffer)) + (t ;make a new indirect buffer for displaying the link + (let* ((indirect-buffer-name (concat (buffer-name) "(Clone)")) + (indirect-buffer + (or (get-buffer indirect-buffer-name) + (make-indirect-buffer (current-buffer) + indirect-buffer-name + 'clone)))) + (with-current-buffer indirect-buffer (org-overview)) + indirect-buffer)))) + +(defun org-link--search-radio-target (target) + "Search a radio target matching TARGET in current buffer. +White spaces are not significant." + (let ((re (format "<<<%s>>>" + (mapconcat #'regexp-quote + (split-string target) + "[ \t]+\\(?:\n[ \t]*\\)?"))) + (origin (point))) + (goto-char (point-min)) + (catch :radio-match + (while (re-search-forward re nil t) + (forward-char -1) + (let ((object (org-element-context))) + (when (eq (org-element-type object) 'radio-target) + (goto-char (org-element-property :begin object)) + (org-show-context 'link-search) + (throw :radio-match nil)))) + (goto-char origin) + (user-error "No match for radio target: %s" target)))) + + +;;; Public API + +(defun org-link-types () + "Return a list of known link types." + (mapcar #'car org-link-parameters)) + +(defun org-link-get-parameter (type key) + "Get TYPE link property for KEY. +TYPE is a string and KEY is a plist keyword. See +`org-link-parameters' for supported keywords." + (plist-get (cdr (assoc type org-link-parameters)) + key)) + +(defun org-link-set-parameters (type &rest parameters) + "Set link TYPE properties to PARAMETERS. +PARAMETERS should be keyword value pairs. See +`org-link-parameters' for supported keys." + (let ((data (assoc type org-link-parameters))) + (if data (setcdr data (org-combine-plists (cdr data) parameters)) + (push (cons type parameters) org-link-parameters) + (org-link-make-regexps) + (when (featurep 'org-element) (org-element-update-syntax))))) + +(defun org-link-make-regexps () + "Update the link regular expressions. +This should be called after the variable `org-link-parameters' has changed." + (let ((types-re (regexp-opt (org-link-types) t))) + (setq org-link-types-re + (concat "\\`" types-re ":") + org-link-angle-re + (format "<%s:\\([^>\n]*\\(?:\n[ \t]*[^> \t\n][^>\n]*\\)*\\)>" + types-re) + org-link-plain-re + (concat + "\\<" types-re ":" + "\\([^][ \t\n()<>]+\\(?:([[:word:]0-9_]+)\\|\\([^[:punct:] \t\n]\\|/\\)\\)\\)") + ;; "\\([^]\t\n\r<>() ]+[^]\t\n\r<>,.;() ]\\)") + org-link-bracket-re + (rx (seq "[[" + ;; URI part: match group 1. + (group + ;; Allow an even number of backslashes right + ;; before the closing bracket. + (or (one-or-more "\\\\") + (and (*? anything) + (not (any "\\")) + (zero-or-more "\\\\")))) + "]" + ;; Description (optional): match group 2. + (opt "[" (group (+? anything)) "]") + "]")) + org-link-any-re + (concat "\\(" org-link-bracket-re "\\)\\|\\(" + org-link-angle-re "\\)\\|\\(" + org-link-plain-re "\\)")))) + +(defun org-link-complete-file (&optional arg) + "Create a file link using completion." + (let ((file (read-file-name "File: ")) + (pwd (file-name-as-directory (expand-file-name "."))) + (pwd1 (file-name-as-directory (abbreviate-file-name + (expand-file-name "."))))) + (cond ((equal arg '(16)) + (concat "file:" + (abbreviate-file-name (expand-file-name file)))) + ((string-match + (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) + (concat "file:" (match-string 1 file))) + ((string-match + (concat "^" (regexp-quote pwd) "\\(.+\\)") + (expand-file-name file)) + (concat "file:" + (match-string 1 (expand-file-name file)))) + (t (concat "file:" file))))) + +(defun org-link-email-description (&optional fmt) + "Return the description part of an email link. +This takes information from `org-store-link-plist' and formats it +according to FMT (default from `org-link-email-description-format')." + (setq fmt (or fmt org-link-email-description-format)) + (let* ((p org-store-link-plist) + (to (plist-get p :toaddress)) + (from (plist-get p :fromaddress)) + (table + (list + (cons "%c" (plist-get p :fromto)) + (cons "%F" (plist-get p :from)) + (cons "%f" (or (plist-get p :fromname) (plist-get p :fromaddress) "?")) + (cons "%T" (plist-get p :to)) + (cons "%t" (or (plist-get p :toname) (plist-get p :toaddress) "?")) + (cons "%s" (plist-get p :subject)) + (cons "%d" (plist-get p :date)) + (cons "%m" (plist-get p :message-id))))) + (when (string-match "%c" fmt) + ;; Check if the user wrote this message + (if (and org-link-from-user-regexp from to + (save-match-data (string-match org-link-from-user-regexp from))) + (setq fmt (replace-match "to %t" t t fmt)) + (setq fmt (replace-match "from %f" t t fmt)))) + (org-replace-escapes fmt table))) + +(defun org-link-store-props (&rest plist) + "Store link properties. +The properties are pre-processed by extracting names, addresses +and dates." + (let ((x (plist-get plist :from))) + (when x + (let ((adr (mail-extract-address-components x))) + (setq plist (plist-put plist :fromname (car adr))) + (setq plist (plist-put plist :fromaddress (nth 1 adr)))))) + (let ((x (plist-get plist :to))) + (when x + (let ((adr (mail-extract-address-components x))) + (setq plist (plist-put plist :toname (car adr))) + (setq plist (plist-put plist :toaddress (nth 1 adr)))))) + (let ((x (ignore-errors (date-to-time (plist-get plist :date))))) + (when x + (setq plist (plist-put plist :date-timestamp + (format-time-string + (org-time-stamp-format t) x))) + (setq plist (plist-put plist :date-timestamp-inactive + (format-time-string + (org-time-stamp-format t t) x))))) + (let ((from (plist-get plist :from)) + (to (plist-get plist :to))) + (when (and from to org-link-from-user-regexp) + (setq plist + (plist-put plist :fromto + (if (string-match org-link-from-user-regexp from) + (concat "to %t") + (concat "from %f")))))) + (setq org-store-link-plist plist)) + +(defun org-link-add-props (&rest plist) + "Add these properties to the link property list." + (let (key value) + (while plist + (setq key (pop plist) value (pop plist)) + (setq org-store-link-plist + (plist-put org-store-link-plist key value))))) + +(defun org-link-encode (text table) + "Return percent escaped representation of string TEXT. +TEXT is a string with the text to escape. TABLE is a list of +characters that should be escaped." + (mapconcat + (lambda (c) + (if (memq c table) + (mapconcat (lambda (e) (format "%%%.2X" e)) + (or (encode-coding-char c 'utf-8) + (error "Unable to percent escape character: %c" c)) + "") + (char-to-string c))) + text "")) + +(defun org-link-decode (s) + "Decode percent-encoded parts in string S. +E.g. \"%C3%B6\" becomes the german o-Umlaut." + (replace-regexp-in-string "\\(%[0-9A-Za-z]\\{2\\}\\)+" + #'org-link--decode-compound s t t)) + +(defun org-link-escape (link) + "Backslash-escape sensitive characters in string LINK." + ;; Escape closing square brackets followed by another square bracket + ;; or at the end of the link. Also escape final backslashes so that + ;; we do not escape inadvertently URI's closing bracket. + (with-temp-buffer + (insert link) + (insert (make-string (- (skip-chars-backward "\\\\")) + ?\\)) + (while (search-backward "\]" nil t) + (when (looking-at-p "\\]\\(?:[][]\\|\\'\\)") + (insert (make-string (1+ (- (skip-chars-backward "\\\\"))) + ?\\)))) + (buffer-string))) + +(defun org-link-unescape (link) + "Remove escaping backslash characters from string LINK." + (with-temp-buffer + (save-excursion (insert link)) + (while (re-search-forward "\\(\\\\+\\)\\]\\(?:[][]\\|\\'\\)" nil t) + (replace-match (make-string (/ (- (match-end 1) (match-beginning 1)) 2) + ?\\) + nil t nil 1)) + (goto-char (point-max)) + (delete-char (/ (- (skip-chars-backward "\\\\")) 2)) + (buffer-string))) + +(defun org-link-make-string (link &optional description) + "Make a bracket link, consisting of LINK and DESCRIPTION. +LINK is escaped with backslashes for inclusion in buffer." + (unless (org-string-nw-p link) (error "Empty link")) + (let* ((uri (org-link-escape link)) + (zero-width-space (string ?\x200B)) + (description + (and (org-string-nw-p description) + ;; Description cannot contain two consecutive square + ;; brackets, or end with a square bracket. To prevent + ;; this, insert a zero width space character between + ;; the brackets, or at the end of the description. + (replace-regexp-in-string + "\\(]\\)\\(]\\)" + (concat "\\1" zero-width-space "\\2") + (replace-regexp-in-string "]\\'" + (concat "\\&" zero-width-space) + (org-trim description)))))) + (format "[[%s]%s]" + uri + (if description (format "[%s]" description) "")))) + +(defun org-store-link-functions () + "List of functions that are called to create and store a link. + +The functions are defined in the `:store' property of +`org-link-parameters'. + +Each function will be called in turn until one returns a non-nil +value. Each function should check if it is responsible for +creating this link (for example by looking at the major mode). +If not, it must exit and return nil. If yes, it should return +a non-nil value after calling `org-link-store-props' with a list +of properties and values. Special properties are: + +:type The link prefix, like \"http\". This must be given. +:link The link, like \"http://www.astro.uva.nl/~dominik\". + This is obligatory as well. +:description Optional default description for the second pair + of brackets in an Org mode link. The user can still change + this when inserting this link into an Org mode buffer. + +In addition to these, any additional properties can be specified +and then used in capture templates." + (cl-loop for link in org-link-parameters + with store-func + do (setq store-func (org-link-get-parameter (car link) :store)) + if store-func + collect store-func)) + +(defun org-link-expand-abbrev (link) + "Replace link abbreviations in LINK string. +Abbreviations are defined in `org-link-abbrev-alist'." + (if (not (string-match "^\\([^:]*\\)\\(::?\\(.*\\)\\)?$" link)) link + (let* ((key (match-string 1 link)) + (as (or (assoc key org-link-abbrev-alist-local) + (assoc key org-link-abbrev-alist))) + (tag (and (match-end 2) (match-string 3 link))) + rpl) + (if (not as) + link + (setq rpl (cdr as)) + (cond + ((symbolp rpl) (funcall rpl tag)) + ((string-match "%(\\([^)]+\\))" rpl) + (replace-match + (save-match-data + (funcall (intern-soft (match-string 1 rpl)) tag)) t t rpl)) + ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) + ((string-match "%h" rpl) + (replace-match (url-hexify-string (or tag "")) t t rpl)) + (t (concat rpl tag))))))) + +(defun org-link-open (link &optional arg) + "Open a link object LINK. +Optional argument is passed to `org-open-file' when S is +a \"file\" link." + (let ((type (org-element-property :type link)) + (path (org-element-property :path link))) + (cond + ((equal type "file") + (if (string-match "[*?{]" (file-name-nondirectory path)) + (dired path) + ;; Look into `org-link-parameters' in order to find + ;; a DEDICATED-FUNCTION to open file. The function will be + ;; applied on raw link instead of parsed link due to the + ;; limitation in `org-add-link-type' ("open" function called + ;; with a single argument). If no such function is found, + ;; fallback to `org-open-file'. + (let* ((option (org-element-property :search-option link)) + (app (org-element-property :application link)) + (dedicated-function + (org-link-get-parameter (if app (concat type "+" app) type) + :follow))) + (if dedicated-function + (funcall dedicated-function + (concat path + (and option (concat "::" option)))) + (apply #'org-open-file + path + (cond (arg) + ((equal app "emacs") 'emacs) + ((equal app "sys") 'system)) + (cond ((not option) nil) + ((string-match-p "\\`[0-9]+\\'" option) + (list (string-to-number option))) + (t (list nil option)))))))) + ((functionp (org-link-get-parameter type :follow)) + (funcall (org-link-get-parameter type :follow) path)) + ((member type '("coderef" "custom-id" "fuzzy" "radio")) + (unless (run-hook-with-args-until-success 'org-open-link-functions path) + (if (not arg) (org-mark-ring-push) + (switch-to-buffer-other-window (org-link--buffer-for-internals))) + (let ((destination + (org-with-wide-buffer + (if (equal type "radio") + (org-link--search-radio-target + (org-element-property :path link)) + (org-link-search + (pcase type + ("custom-id" (concat "#" path)) + ("coderef" (format "(%s)" path)) + (_ path)) + ;; Prevent fuzzy links from matching themselves. + (and (equal type "fuzzy") + (+ 2 (org-element-property :begin link))))) + (point)))) + (unless (and (<= (point-min) destination) + (>= (point-max) destination)) + (widen)) + (goto-char destination)))) + (t (browse-url-at-point))))) + +(defun org-link-open-from-string (s &optional arg) + "Open a link in the string S, as if it was in Org mode. +Optional argument is passed to `org-open-file' when S is +a \"file\" link." + (interactive "sLink: \nP") + (pcase (with-temp-buffer + (let ((org-inhibit-startup nil)) + (insert s) + (org-mode) + (goto-char (point-min)) + (org-element-link-parser))) + (`nil (user-error "No valid link in %S" s)) + (link (org-link-open link arg)))) + +(defun org-link-search (s &optional avoid-pos stealth) + "Search for a search string S. + +If S starts with \"#\", it triggers a custom ID search. + +If S is enclosed within parenthesis, it initiates a coderef +search. + +If S is surrounded by forward slashes, it is interpreted as +a regular expression. In Org mode files, this will create an +`org-occur' sparse tree. In ordinary files, `occur' will be used +to list matches. If the current buffer is in `dired-mode', grep +will be used to search in all files. + +When AVOID-POS is given, ignore matches near that position. + +When optional argument STEALTH is non-nil, do not modify +visibility around point, thus ignoring `org-show-context-detail' +variable. + +Search is case-insensitive and ignores white spaces. Return type +of matched result, which is either `dedicated' or `fuzzy'." + (unless (org-string-nw-p s) (error "Invalid search string \"%s\"" s)) + (let* ((case-fold-search t) + (origin (point)) + (normalized (replace-regexp-in-string "\n[ \t]*" " " s)) + (starred (eq (string-to-char normalized) ?*)) + (words (split-string (if starred (substring s 1) s))) + (s-multi-re (mapconcat #'regexp-quote words "\\(?:[ \t\n]+\\)")) + (s-single-re (mapconcat #'regexp-quote words "[ \t]+")) + type) + (cond + ;; Check if there are any special search functions. + ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) + ((eq (string-to-char s) ?#) + ;; Look for a custom ID S if S starts with "#". + (let* ((id (substring normalized 1)) + (match (org-find-property "CUSTOM_ID" id))) + (if match (progn (goto-char match) (setf type 'dedicated)) + (error "No match for custom ID: %s" id)))) + ((string-match "\\`(\\(.*\\))\\'" normalized) + ;; Look for coderef targets if S is enclosed within parenthesis. + (let ((coderef (match-string-no-properties 1 normalized)) + (re (substring s-single-re 1 -1))) + (goto-char (point-min)) + (catch :coderef-match + (while (re-search-forward re nil t) + (let ((element (org-element-at-point))) + (when (and (memq (org-element-type element) + '(example-block src-block)) + (org-match-line + (concat ".*?" (org-src-coderef-regexp + (org-src-coderef-format element) + coderef)))) + (setq type 'dedicated) + (goto-char (match-beginning 2)) + (throw :coderef-match nil)))) + (goto-char origin) + (error "No match for coderef: %s" coderef)))) + ((string-match "\\`/\\(.*\\)/\\'" normalized) + ;; Look for a regular expression. + (funcall (if (derived-mode-p 'org-mode) #'org-occur #'org-do-occur) + (match-string 1 s))) + ;; From here, we handle fuzzy links. + ;; + ;; Look for targets, only if not in a headline search. + ((and (not starred) + (let ((target (format "<<%s>>" s-multi-re))) + (catch :target-match + (goto-char (point-min)) + (while (re-search-forward target nil t) + (backward-char) + (let ((context (org-element-context))) + (when (eq (org-element-type context) 'target) + (setq type 'dedicated) + (goto-char (org-element-property :begin context)) + (throw :target-match t)))) + nil)))) + ;; Look for elements named after S, only if not in a headline + ;; search. + ((and (not starred) + (let ((name (format "^[ \t]*#\\+NAME: +%s[ \t]*$" s-single-re))) + (catch :name-match + (goto-char (point-min)) + (while (re-search-forward name nil t) + (let ((element (org-element-at-point))) + (when (equal words + (split-string + (org-element-property :name element))) + (setq type 'dedicated) + (beginning-of-line) + (throw :name-match t)))) + nil)))) + ;; Regular text search. Prefer headlines in Org mode buffers. + ;; Ignore COMMENT keyword, TODO keywords, priority cookies, + ;; statistics cookies and tags. + ((and (derived-mode-p 'org-mode) + (let ((title-re + (format "%s.*\\(?:%s[ \t]\\)?.*%s" + org-outline-regexp-bol + org-comment-string + (mapconcat #'regexp-quote words ".+"))) + (cookie-re "\\[[0-9]*\\(?:%\\|/[0-9]*\\)\\]") + (comment-re (format "\\`%s[ \t]+" org-comment-string))) + (goto-char (point-min)) + (catch :found + (while (re-search-forward title-re nil t) + (when (equal words + (split-string + (replace-regexp-in-string + cookie-re "" + (replace-regexp-in-string + comment-re "" (org-get-heading t t t))))) + (throw :found t))) + nil))) + (beginning-of-line) + (setq type 'dedicated)) + ;; Offer to create non-existent headline depending on + ;; `org-link-search-must-match-exact-headline'. + ((and (derived-mode-p 'org-mode) + (eq org-link-search-must-match-exact-headline 'query-to-create) + (yes-or-no-p "No match - create this as a new heading? ")) + (goto-char (point-max)) + (unless (bolp) (newline)) + (org-insert-heading nil t t) + (insert s "\n") + (beginning-of-line 0)) + ;; Only headlines are looked after. No need to process + ;; further: throw an error. + ((and (derived-mode-p 'org-mode) + (or starred org-link-search-must-match-exact-headline)) + (goto-char origin) + (error "No match for fuzzy expression: %s" normalized)) + ;; Regular text search. + ((catch :fuzzy-match + (goto-char (point-min)) + (while (re-search-forward s-multi-re nil t) + ;; Skip match if it contains AVOID-POS or it is included in + ;; a link with a description but outside the description. + (unless (or (and avoid-pos + (<= (match-beginning 0) avoid-pos) + (> (match-end 0) avoid-pos)) + (and (save-match-data + (org-in-regexp org-link-bracket-re)) + (match-beginning 3) + (or (> (match-beginning 3) (point)) + (<= (match-end 3) (point))) + (org-element-lineage + (save-match-data (org-element-context)) + '(link) t))) + (goto-char (match-beginning 0)) + (setq type 'fuzzy) + (throw :fuzzy-match t))) + nil)) + ;; All failed. Throw an error. + (t (goto-char origin) + (error "No match for fuzzy expression: %s" normalized))) + ;; Disclose surroundings of match, if appropriate. + (when (and (derived-mode-p 'org-mode) (not stealth)) + (org-show-context 'link-search)) + type)) + +(defun org-link-heading-search-string (&optional string) + "Make search string for the current headline or STRING." + (let ((s (or string + (and (derived-mode-p 'org-mode) + (save-excursion + (org-back-to-heading t) + (org-element-property :raw-value + (org-element-at-point)))))) + (lines org-link-context-for-files)) + (unless string (setq s (concat "*" s))) ;Add * for headlines + (setq s (replace-regexp-in-string "\\[[0-9]+%\\]\\|\\[[0-9]+/[0-9]+\\]" "" s)) + (when (and string (integerp lines) (> lines 0)) + (let ((slines (org-split-string s "\n"))) + (when (< lines (length slines)) + (setq s (mapconcat + #'identity + (reverse (nthcdr (- (length slines) lines) + (reverse slines))) "\n"))))) + (mapconcat #'identity (split-string s) " "))) + +(defun org-link-display-format (s) + "Replace links in string S with their description. +If there is no description, use the link target." + (save-match-data + (replace-regexp-in-string + org-link-bracket-re + (lambda (m) (or (match-string 2 m) (match-string 1 m))) + s nil t))) + +(defun org-link-add-angle-brackets (s) + "Wrap string S within angle brackets." + (unless (equal (substring s 0 1) "<") (setq s (concat "<" s))) + (unless (equal (substring s -1) ">") (setq s (concat s ">"))) + s) + + +;;; Built-in link types + +;;;; "doi" link type +(defun org-link--open-doi (path) + "Open a \"doi\" type link. +PATH is a the path to search for, as a string." + (browse-url (url-encode-url (concat org-link-doi-server-url path)))) + +(org-link-set-parameters "doi" :follow #'org-link--open-doi) + +;;;; "elisp" link type +(defun org-link--open-elisp (path) + "Open a \"elisp\" type link. +PATH is the sexp to evaluate, as a string." + (if (or (and (org-string-nw-p org-link-elisp-skip-confirm-regexp) + (string-match-p org-link-elisp-skip-confirm-regexp path)) + (not org-link-elisp-confirm-function) + (funcall org-link-elisp-confirm-function + (format "Execute %S as Elisp? " + (org-add-props path nil 'face 'org-warning)))) + (message "%s => %s" path + (if (eq ?\( (string-to-char path)) + (eval (read path)) + (call-interactively (read path)))) + (user-error "Abort"))) + +(org-link-set-parameters "elisp" :follow #'org-link--open-elisp) + +;;;; "file" link type +(org-link-set-parameters "file" :complete #'org-link-complete-file) + +;;;; "help" link type +(defun org-link--open-help (path) + "Open a \"help\" type link. +PATH is a symbol name, as a string." + (pcase (intern path) + ((and (pred fboundp) variable) (describe-function variable)) + ((and (pred boundp) function) (describe-variable function)) + (name (user-error "Unknown function or variable: %s" name)))) + +(org-link-set-parameters "help" :follow #'org-link--open-help) + +;;;; "http", "https", "mailto", "ftp", and "news" link types +(dolist (scheme '("ftp" "http" "https" "mailto" "news")) + (org-link-set-parameters scheme + :follow + (lambda (url) (browse-url (concat scheme ":" url))))) + +;;;; "shell" link type +(defun org-link--open-shell (path) + "Open a \"shell\" type link. +PATH is the command to execute, as a string." + (if (or (and (org-string-nw-p org-link-shell-skip-confirm-regexp) + (string-match-p org-link-shell-skip-confirm-regexp path)) + (not org-link-shell-confirm-function) + (funcall org-link-shell-confirm-function + (format "Execute %S in shell? " + (org-add-props path nil 'face 'org-warning)))) + (let ((buf (generate-new-buffer "*Org Shell Output*"))) + (message "Executing %s" path) + (shell-command path buf) + (when (featurep 'midnight) + (setq clean-buffer-list-kill-buffer-names + (cons (buffer-name buf) + clean-buffer-list-kill-buffer-names)))) + (user-error "Abort"))) + +(org-link-set-parameters "shell" :follow #'org-link--open-shell) + + +;;; Interactive Functions + +;;;###autoload +(defun org-next-link (&optional search-backward) + "Move forward to the next link. +If the link is in hidden text, expose it. When SEARCH-BACKWARD +is non-nil, move backward." + (interactive) + (let ((pos (point)) + (search-fun (if search-backward #'re-search-backward + #'re-search-forward))) + ;; Tweak initial position. If last search failed, wrap around. + ;; Otherwise, make sure we do not match current link. + (cond + ((not (and org-link--search-failed (eq this-command last-command))) + (cond + ((and (not search-backward) (looking-at org-link-any-re)) + (goto-char (match-end 0))) + (search-backward + (pcase (org-in-regexp org-link-any-re nil t) + (`(,beg . ,_) (goto-char beg)) + (_ nil))) + (t nil))) + (search-backward + (goto-char (point-max)) + (message "Link search wrapped back to end of buffer")) + (t + (goto-char (point-min)) + (message "Link search wrapped back to beginning of buffer"))) + (setq org-link--search-failed nil) + (catch :found + (while (funcall search-fun org-link-any-re nil t) + (let ((context (save-excursion + (unless search-backward (forward-char -1)) + (org-element-context)))) + (pcase (org-element-lineage context '(link) t) + (`nil nil) + (link + (goto-char (org-element-property :begin link)) + (when (org-invisible-p) (org-show-context)) + (throw :found t))))) + (goto-char pos) + (setq org-link--search-failed t) + (message "No further link found")))) + +;;;###autoload +(defun org-previous-link () + "Move backward to the previous link. +If the link is in hidden text, expose it." + (interactive) + (org-next-link t)) + +;;;###autoload +(defun org-toggle-link-display () + "Toggle the literal or descriptive display of links." + (interactive) + (if org-link-descriptive (remove-from-invisibility-spec '(org-link)) + (add-to-invisibility-spec '(org-link))) + (org-restart-font-lock) + (setq org-link-descriptive (not org-link-descriptive))) + +;;;###autoload +(defun org-store-link (arg &optional interactive?) + "Store a link to the current location. +\\<org-mode-map> +This link is added to `org-stored-links' and can later be inserted +into an Org buffer with `org-insert-link' (`\\[org-insert-link]'). + +For some link types, a `\\[universal-argument]' prefix ARG is interpreted. \ +A single +`\\[universal-argument]' negates `org-context-in-file-links' for file links or +`org-gnus-prefer-web-links' for links to Usenet articles. + +A `\\[universal-argument] \\[universal-argument]' prefix ARG forces \ +skipping storing functions that are not +part of Org core. + +A `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \ +prefix ARG forces storing a link for each line in the +active region. + +Assume the function is called interactively if INTERACTIVE? is +non-nil." + (interactive "P\np") + (org-load-modules-maybe) + (if (and (equal arg '(64)) (org-region-active-p)) + (save-excursion + (let ((end (region-end))) + (goto-char (region-beginning)) + (set-mark (point)) + (while (< (point-at-eol) end) + (move-end-of-line 1) (activate-mark) + (let (current-prefix-arg) + (call-interactively 'org-store-link)) + (move-beginning-of-line 2) + (set-mark (point))))) + (setq org-store-link-plist nil) + (let (link cpltxt desc description search txt custom-id agenda-link) + (cond + ;; Store a link using an external link type, if any function is + ;; available. If more than one can generate a link from current + ;; location, ask which one to use. + ((and (not (equal arg '(16))) + (let ((results-alist nil)) + (dolist (f (org-store-link-functions)) + (when (funcall f) + ;; XXX: return value is not link's plist, so we + ;; store the new value before it is modified. It + ;; would be cleaner to ask store link functions to + ;; return the plist instead. + (push (cons f (copy-sequence org-store-link-plist)) + results-alist))) + (pcase results-alist + (`nil nil) + (`((,_ . ,_)) t) ;single choice: nothing to do + (`((,name . ,_) . ,_) + ;; Reinstate link plist associated to the chosen + ;; function. + (apply #'org-link-store-props + (cdr (assoc-string + (completing-read + "Which function for creating the link? " + (mapcar #'car results-alist) + nil t (symbol-name name)) + results-alist))) + t)))) + (setq link (plist-get org-store-link-plist :link)) + (setq desc (or (plist-get org-store-link-plist :description) + link))) + + ;; Store a link from a remote editing buffer. + ((org-src-edit-buffer-p) + (let ((coderef-format (org-src-coderef-format)) + (format-link + (lambda (label) + (if org-src-source-file-name + (format "file:%s::(%s)" org-src-source-file-name label) + (format "(%s)" label))))) + (cond + ;; Code references do not exist in this type of buffer. + ;; Pretend we're linking from the source buffer directly. + ((not (memq (org-src-source-type) '(example-block src-block))) + (with-current-buffer (org-src-source-buffer) + (org-store-link arg interactive?)) + (setq link nil)) + ;; A code reference exists. Use it. + ((save-excursion + (beginning-of-line) + (re-search-forward (org-src-coderef-regexp coderef-format) + (line-end-position) + t)) + (setq link (funcall format-link (match-string-no-properties 3)))) + ;; No code reference. Create a new one then store the link + ;; to it, but only in the function is called interactively. + (interactive? + (end-of-line) + (let* ((label (read-string "Code line label: ")) + (reference (format coderef-format label)) + (gc (- 79 (length reference)))) + (if (< (current-column) gc) + (org-move-to-column gc t) + (insert " ")) + (insert reference) + (setq link (funcall format-link label)))) + ;; No code reference, and non-interactive call. Don't know + ;; what to do. Give up. + (t (setq link nil))))) + + ;; We are in the agenda, link to referenced location + ((equal (bound-and-true-p org-agenda-buffer-name) (buffer-name)) + (let ((m (or (get-text-property (point) 'org-hd-marker) + (get-text-property (point) 'org-marker)))) + (when m + (org-with-point-at m + (setq agenda-link (org-store-link nil interactive?)))))) + + ((eq major-mode 'calendar-mode) + (let ((cd (calendar-cursor-to-date))) + (setq link + (format-time-string + (car org-time-stamp-formats) + (apply 'encode-time + (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) + nil nil nil)))) + (org-link-store-props :type "calendar" :date cd))) + + ((eq major-mode 'help-mode) + (setq link (concat "help:" (save-excursion + (goto-char (point-min)) + (looking-at "^[^ ]+") + (match-string 0)))) + (org-link-store-props :type "help")) + + ((eq major-mode 'w3-mode) + (setq cpltxt (if (and (buffer-name) + (not (string-match "Untitled" (buffer-name)))) + (buffer-name) + (url-view-url t)) + link (url-view-url t)) + (org-link-store-props :type "w3" :url (url-view-url t))) + + ((eq major-mode 'image-mode) + (setq cpltxt (concat "file:" + (abbreviate-file-name buffer-file-name)) + link cpltxt) + (org-link-store-props :type "image" :file buffer-file-name)) + + ;; In dired, store a link to the file of the current line + ((derived-mode-p 'dired-mode) + (let ((file (dired-get-filename nil t))) + (setq file (if file + (abbreviate-file-name + (expand-file-name (dired-get-filename nil t))) + ;; otherwise, no file so use current directory. + default-directory)) + (setq cpltxt (concat "file:" file) + link cpltxt))) + + ((setq search (run-hook-with-args-until-success + 'org-create-file-search-functions)) + (setq link (concat "file:" (abbreviate-file-name buffer-file-name) + "::" search)) + (setq cpltxt (or description link))) + + ((and (buffer-file-name (buffer-base-buffer)) (derived-mode-p 'org-mode)) + (org-with-limited-levels + (setq custom-id (org-entry-get nil "CUSTOM_ID")) + (cond + ;; Store a link using the target at point + ((org-in-regexp "[^<]<<\\([^<>]+\\)>>[^>]" 1) + (setq cpltxt + (concat "file:" + (abbreviate-file-name + (buffer-file-name (buffer-base-buffer))) + "::" (match-string 1)) + link cpltxt)) + ((and (featurep 'org-id) + (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 custom-id)))) + (and org-id-link-to-org-use-id (org-entry-get nil "ID")))) + ;; Store a link using the ID at point + (setq link (condition-case nil + (prog1 (org-id-store-link) + (setq desc (or (plist-get org-store-link-plist + :description) + ""))) + (error + ;; Probably before first headline, link only to file + (concat "file:" + (abbreviate-file-name + (buffer-file-name (buffer-base-buffer)))))))) + (t + ;; Just link to current headline + (setq cpltxt (concat "file:" + (abbreviate-file-name + (buffer-file-name (buffer-base-buffer))))) + ;; Add a context search string + (when (org-xor org-link-context-for-files (equal arg '(4))) + (let* ((element (org-element-at-point)) + (name (org-element-property :name element))) + (setq txt (cond + ((org-at-heading-p) nil) + (name) + ((org-region-active-p) + (buffer-substring (region-beginning) (region-end))))) + (when (or (null txt) (string-match "\\S-" txt)) + (setq cpltxt + (concat cpltxt "::" + (condition-case nil + (org-link-heading-search-string txt) + (error ""))) + desc (or name + (nth 4 (ignore-errors (org-heading-components))) + "NONE"))))) + (when (string-match "::\\'" cpltxt) + (setq cpltxt (substring cpltxt 0 -2))) + (setq link cpltxt))))) + + ((buffer-file-name (buffer-base-buffer)) + ;; Just link to this file here. + (setq cpltxt (concat "file:" + (abbreviate-file-name + (buffer-file-name (buffer-base-buffer))))) + ;; Add a context string. + (when (org-xor org-link-context-for-files (equal arg '(4))) + (setq txt (if (org-region-active-p) + (buffer-substring (region-beginning) (region-end)) + (buffer-substring (point-at-bol) (point-at-eol)))) + ;; Only use search option if there is some text. + (when (string-match "\\S-" txt) + (setq cpltxt + (concat cpltxt "::" (org-link-heading-search-string txt)) + desc "NONE"))) + (setq link cpltxt)) + + (interactive? + (user-error "No method for storing a link from this buffer")) + + (t (setq link nil))) + + ;; We're done setting link and desc, clean up + (when (consp link) (setq cpltxt (car link) link (cdr link))) + (setq link (or link cpltxt) + desc (or desc cpltxt)) + (cond ((not desc)) + ((equal desc "NONE") (setq desc nil)) + (t (setq desc (org-link-display-format desc)))) + ;; Return the link + (if (not (and interactive? link)) + (or agenda-link (and link (org-link-make-string link desc))) + (push (list link desc) org-stored-links) + (message "Stored: %s" (or desc link)) + (when custom-id + (setq link (concat "file:" (abbreviate-file-name + (buffer-file-name)) "::#" custom-id)) + (push (list link desc) org-stored-links)) + (car org-stored-links))))) + +;;;###autoload +(defun org-insert-link (&optional complete-file link-location description) + "Insert a link. At the prompt, enter the link. + +Completion can be used to insert any of the link protocol prefixes in use. + +The history can be used to select a link previously stored with +`org-store-link'. When the empty string is entered (i.e. if you just +press `RET' at the prompt), the link defaults to the most recently +stored link. As `SPC' triggers completion in the minibuffer, you need to +use `M-SPC' or `C-q SPC' to force the insertion of a space character. + +You will also be prompted for a description, and if one is given, it will +be displayed in the buffer instead of the link. + +If there is already a link at point, this command will allow you to edit +link and description parts. + +With a `\\[universal-argument]' prefix, prompts for a file to link to. The \ +file name can be +selected using completion. The path to the file will be relative to the +current directory if the file is in the current directory or a subdirectory. +Otherwise, the link will be the absolute path as completed in the minibuffer +\(i.e. normally ~/path/to/file). You can configure this behavior using the +option `org-link-file-path-type'. + +With a `\\[universal-argument] \\[universal-argument]' prefix, enforce an \ +absolute path even if the file is in +the current directory or below. + +A `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \ +prefix negates `org-link-keep-stored-after-insertion'. + +If the LINK-LOCATION parameter is non-nil, this value will be used as +the link location instead of reading one interactively. + +If the DESCRIPTION parameter is non-nil, this value will be used as the +default description. Otherwise, if `org-link-make-description-function' +is non-nil, this function will be called with the link target, and the +result will be the default link description. When called non-interactively, +don't allow to edit the default description." + (interactive "P") + (let* ((wcf (current-window-configuration)) + (origbuf (current-buffer)) + (region (when (org-region-active-p) + (buffer-substring (region-beginning) (region-end)))) + (remove (and region (list (region-beginning) (region-end)))) + (desc region) + (link link-location) + (abbrevs org-link-abbrev-alist-local) + entry all-prefixes auto-desc) + (cond + (link-location) ; specified by arg, just use it. + ((org-in-regexp org-link-bracket-re 1) + ;; We do have a link at point, and we are going to edit it. + (setq remove (list (match-beginning 0) (match-end 0))) + (setq desc (when (match-end 2) (match-string-no-properties 2))) + (setq link (read-string "Link: " + (org-link-unescape + (match-string-no-properties 1))))) + ((or (org-in-regexp org-link-angle-re) + (org-in-regexp org-link-plain-re)) + ;; Convert to bracket link + (setq remove (list (match-beginning 0) (match-end 0)) + link (read-string "Link: " + (org-unbracket-string "<" ">" (match-string 0))))) + ((member complete-file '((4) (16))) + ;; Completing read for file names. + (setq link (org-link-complete-file complete-file))) + (t + ;; Read link, with completion for stored links. + (org-link--fontify-links-to-this-file) + (org-switch-to-buffer-other-window "*Org Links*") + (with-current-buffer "*Org Links*" + (erase-buffer) + (insert "Insert a link. +Use TAB to complete link prefixes, then RET for type-specific completion support\n") + (when org-stored-links + (insert "\nStored links are available with <up>/<down> or M-p/n \ +\(most recent with RET):\n\n") + (insert (mapconcat #'org-link--prettify + (reverse org-stored-links) + "\n"))) + (goto-char (point-min))) + (let ((cw (selected-window))) + (select-window (get-buffer-window "*Org Links*" 'visible)) + (with-current-buffer "*Org Links*" (setq truncate-lines t)) + (unless (pos-visible-in-window-p (point-max)) + (org-fit-window-to-buffer)) + (and (window-live-p cw) (select-window cw))) + (setq all-prefixes (append (mapcar #'car abbrevs) + (mapcar #'car org-link-abbrev-alist) + (org-link-types))) + (unwind-protect + ;; Fake a link history, containing the stored links. + (let ((org-link--history + (append (mapcar #'car org-stored-links) + org-link--insert-history))) + (setq link + (org-completing-read + "Link: " + (append + (mapcar (lambda (x) (concat x ":")) all-prefixes) + (mapcar #'car org-stored-links)) + nil nil nil + 'org-link--history + (caar org-stored-links))) + (unless (org-string-nw-p link) (user-error "No link selected")) + (dolist (l org-stored-links) + (when (equal link (cadr l)) + (setq link (car l)) + (setq auto-desc t))) + (when (or (member link all-prefixes) + (and (equal ":" (substring link -1)) + (member (substring link 0 -1) all-prefixes) + (setq link (substring link 0 -1)))) + (setq link (with-current-buffer origbuf + (org-link--try-special-completion link))))) + (set-window-configuration wcf) + (kill-buffer "*Org Links*")) + (setq entry (assoc link org-stored-links)) + (or entry (push link org-link--insert-history)) + (setq desc (or desc (nth 1 entry))))) + + (when (funcall (if (equal complete-file '(64)) 'not 'identity) + (not org-link-keep-stored-after-insertion)) + (setq org-stored-links (delq (assoc link org-stored-links) + org-stored-links))) + + (when (and (string-match org-link-plain-re link) + (not (string-match org-ts-regexp link))) + ;; URL-like link, normalize the use of angular brackets. + (setq link (org-unbracket-string "<" ">" link))) + + ;; Check if we are linking to the current file with a search + ;; option If yes, simplify the link by using only the search + ;; option. + (when (and buffer-file-name + (let ((case-fold-search nil)) + (string-match "\\`file:\\(.+?\\)::" link))) + (let ((path (match-string-no-properties 1 link)) + (search (substring-no-properties link (match-end 0)))) + (save-match-data + (when (equal (file-truename buffer-file-name) (file-truename path)) + ;; We are linking to this same file, with a search option + (setq link search))))) + + ;; Check if we can/should use a relative path. If yes, simplify + ;; the link. + (let ((case-fold-search nil)) + (when (string-match "\\`\\(file\\|docview\\):" link) + (let* ((type (match-string-no-properties 0 link)) + (path-start (match-end 0)) + (search (and (string-match "::\\(.*\\)\\'" link) + (match-string 1 link))) + (path + (if search + (substring-no-properties + link path-start (match-beginning 0)) + (substring-no-properties link (match-end 0)))) + (origpath path)) + (cond + ((or (eq org-link-file-path-type 'absolute) + (equal complete-file '(16))) + (setq path (abbreviate-file-name (expand-file-name path)))) + ((eq org-link-file-path-type 'noabbrev) + (setq path (expand-file-name path))) + ((eq org-link-file-path-type 'relative) + (setq path (file-relative-name path))) + (t + (save-match-data + (if (string-match (concat "^" (regexp-quote + (expand-file-name + (file-name-as-directory + default-directory)))) + (expand-file-name path)) + ;; We are linking a file with relative path name. + (setq path (substring (expand-file-name path) + (match-end 0))) + (setq path (abbreviate-file-name (expand-file-name path))))))) + (setq link (concat type path (and search (concat "::" search)))) + (when (equal desc origpath) + (setq desc path))))) + + (unless auto-desc + (let ((initial-input + (cond + (description) + ((not org-link-make-description-function) desc) + (t (condition-case nil + (funcall org-link-make-description-function link desc) + (error + (message "Can't get link description from %S" + (symbol-name org-link-make-description-function)) + (sit-for 2) + nil)))))) + (setq desc (if (called-interactively-p 'any) + (read-string "Description: " initial-input) + initial-input)))) + + (unless (org-string-nw-p desc) (setq desc nil)) + (when remove (apply #'delete-region remove)) + (insert (org-link-make-string link desc)) + ;; Redisplay so as the new link has proper invisible characters. + (sit-for 0))) + +;;;###autoload +(defun org-insert-all-links (arg &optional pre post) + "Insert all links in `org-stored-links'. +When a universal prefix, do not delete the links from `org-stored-links'. +When `ARG' is a number, insert the last N link(s). +`PRE' and `POST' are optional arguments to define a string to +prepend or to append." + (interactive "P") + (let ((org-link-keep-stored-after-insertion (equal arg '(4))) + (links (copy-sequence org-stored-links)) + (pr (or pre "- ")) + (po (or post "\n")) + (cnt 1) l) + (if (null org-stored-links) + (message "No link to insert") + (while (and (or (listp arg) (>= arg cnt)) + (setq l (if (listp arg) + (pop links) + (pop org-stored-links)))) + (setq cnt (1+ cnt)) + (insert pr) + (org-insert-link nil (car l) (or (cadr l) "<no description>")) + (insert po))))) + +;;;###autoload +(defun org-insert-last-stored-link (arg) + "Insert the last link stored in `org-stored-links'." + (interactive "p") + (org-insert-all-links arg "" "\n")) + +;;;###autoload +(defun org-insert-link-global () + "Insert a link like Org mode does. +This command can be called in any mode to insert a link in Org syntax." + (interactive) + (org-load-modules-maybe) + (org-run-like-in-org-mode 'org-insert-link)) + +;;;###autoload +(defun org-update-radio-target-regexp () + "Find all radio targets in this file and update the regular expression. +Also refresh fontification if needed." + (interactive) + (let ((old-regexp org-target-link-regexp) + ;; Some languages, e.g., Chinese, do not use spaces to + ;; separate words. Also allow to surround radio targets with + ;; line-breakable characters. + (before-re "\\(?:^\\|[^[:alnum:]]\\|\\c|\\)\\(") + (after-re "\\)\\(?:$\\|[^[:alnum:]]\\|\\c|\\)") + (targets + (org-with-wide-buffer + (goto-char (point-min)) + (let (rtn) + (while (re-search-forward org-radio-target-regexp nil t) + ;; Make sure point is really within the object. + (backward-char) + (let ((obj (org-element-context))) + (when (eq (org-element-type obj) 'radio-target) + (cl-pushnew (org-element-property :value obj) rtn + :test #'equal)))) + rtn)))) + (setq org-target-link-regexp + (and targets + (concat before-re + (mapconcat + (lambda (x) + (replace-regexp-in-string + " +" "\\s-+" (regexp-quote x) t t)) + targets + "\\|") + after-re))) + (unless (equal old-regexp org-target-link-regexp) + ;; Clean-up cache. + (let ((regexp (cond ((not old-regexp) org-target-link-regexp) + ((not org-target-link-regexp) old-regexp) + (t + (concat before-re + (mapconcat + (lambda (re) + (substring re (length before-re) + (- (length after-re)))) + (list old-regexp org-target-link-regexp) + "\\|") + after-re))))) + (when (featurep 'org-element) + (org-with-point-at 1 + (while (re-search-forward regexp nil t) + (org-element-cache-refresh (match-beginning 1)))))) + ;; Re fontify buffer. + (when (memq 'radio org-highlight-links) + (org-restart-font-lock))))) + + +;;; Initialize Regexps + +(org-link-make-regexps) + + +(provide 'ol) + +;;; ol.el ends here diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 6870b780fa2..7cb5cca34cd 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -46,6 +46,7 @@ ;;; Code: (require 'cl-lib) +(require 'ol) (require 'org) (require 'org-macs) @@ -90,6 +91,7 @@ (defvar org-habit-show-habits) (defvar org-habit-show-habits-only-for-today) (defvar org-habit-show-all-today) +(defvar org-habit-scheduled-past-days) ;; Defined somewhere in this file, but used before definition. (defvar org-agenda-buffer-name "*Org Agenda*") @@ -381,6 +383,9 @@ the daily/weekly agenda, see `org-agenda-skip-function'.") (const :scheduled*) (const :timestamp) (const :sexp)))) + (list :tag "Columns format" + (const org-overriding-columns-format) + (string :tag "Format")) (list :tag "Standard skipping condition" :value (org-agenda-skip-function '(org-agenda-skip-entry-if)) (const org-agenda-skip-function) @@ -461,7 +466,7 @@ type The command type, any of the following symbols: ... A user-defined function. match What to search for: - a single keyword for TODO keyword searches - - a tags match expression for tags searches + - a tags/property/todo match expression for searches - a word search expression for text searches. - a regular expression for occur searches For all other commands, this should be the empty string. @@ -548,11 +553,11 @@ should provide a description for the prefix, like (const :format "" stuck) (const :tag "" :format "" "") ,org-agenda-custom-commands-local-options) - (list :tag "Tags search" + (list :tag "Tags/Property match (all agenda files)" (const :format "" tags) (string :tag "Match") ,org-agenda-custom-commands-local-options) - (list :tag "Tags search, TODO entries only" + (list :tag "Tags/Property match of TODO entries (all agenda files)" (const :format "" tags-todo) (string :tag "Match") ,org-agenda-custom-commands-local-options) @@ -1706,6 +1711,13 @@ Custom commands can set this variable in the options section." :version "26.1" :package-version '(Org . "9.1")) +(defcustom org-agenda-breadcrumbs-separator "->" + "The separator of breadcrumbs in agenda lines." + :group 'org-agenda-line-format + :package-version '(Org . "9.3") + :type 'string + :safe #'stringp) + (defvar org-prefix-format-compiled nil "The compiled prefix format and associated variables. This is a list where first element is a list of variable bindings, and second @@ -2021,7 +2033,8 @@ estimate." The sole argument to the function, which is called once for each possible tag, is a string giving the name of the tag. The function should return either nil if the tag should be included -as normal, or \"-<TAG>\" to exclude the tag. +as normal, \"-<TAG>\" to exclude the tag, or \"+<TAG>\" to exclude +lines not carrying this tag. Note that for the purpose of tag filtering, only the lower-case version of all tags will be considered, so that this function will only ever see the lower-case version of all tags." @@ -2065,6 +2078,23 @@ works you probably want to add it to `org-agenda-custom-commands' for good." (setcdr ass (cdr entry)) (push entry org-agenda-custom-commands)))) +(defmacro org-agenda--insert-overriding-header (default) + "Insert header into agenda view. +The inserted header depends on `org-agenda-overriding-header'. +If the empty string, don't insert a header. If any other string, +insert it as a header. If nil, insert DEFAULT, which should +evaluate to a string." + (declare (debug (form)) (indent defun)) + `(cond + ((not org-agenda-overriding-header) (insert ,default)) + ((equal org-agenda-overriding-header "") nil) + ((stringp org-agenda-overriding-header) + (insert (propertize org-agenda-overriding-header + 'face 'org-agenda-structure) + "\n")) + (t (user-error "Invalid value for `org-agenda-overriding-header': %S" + org-agenda-overriding-header)))) + ;;; Define the org-agenda-mode (defvaralias 'org-agenda-keymap 'org-agenda-mode-map) @@ -2167,29 +2197,36 @@ The following commands are available: \\{org-agenda-mode-map}" (interactive) - (cond (org-agenda-doing-sticky-redo - ;; Refreshing sticky agenda-buffer - ;; - ;; Preserve the value of `org-agenda-local-vars' variables, - ;; while letting `kill-all-local-variables' kill the rest - (let ((save (buffer-local-variables))) - (kill-all-local-variables) - (mapc #'make-local-variable org-agenda-local-vars) - (dolist (elem save) - (pcase elem - (`(,var . ,val) ;ignore unbound variables - (when (and val (memq var org-agenda-local-vars)) - (set var val)))))) - (setq-local org-agenda-this-buffer-is-sticky t)) - (org-agenda-sticky - ;; Creating a sticky Agenda buffer for the first time - (kill-all-local-variables) - (mapc 'make-local-variable org-agenda-local-vars) - (setq-local org-agenda-this-buffer-is-sticky t)) - (t - ;; Creating a non-sticky agenda buffer - (kill-all-local-variables) - (setq-local org-agenda-this-buffer-is-sticky nil))) + (let ((agenda-local-vars-to-keep + '(text-scale-mode-amount + text-scale-mode + text-scale-mode-lighter + face-remapping-alist)) + (save (buffer-local-variables))) + (kill-all-local-variables) + (cl-flet ((reset-saved (var-set) + "Reset variables in VAR-SET to possibly stored value in SAVE." + (dolist (elem save) + (pcase elem + (`(,var . ,val) ;ignore unbound variables + (when (and val (memq var var-set)) + (set var val))))))) + (cond (org-agenda-doing-sticky-redo + ;; Refreshing sticky agenda-buffer + ;; + ;; Preserve the value of `org-agenda-local-vars' variables. + (mapc #'make-local-variable org-agenda-local-vars) + (reset-saved org-agenda-local-vars) + (setq-local org-agenda-this-buffer-is-sticky t)) + (org-agenda-sticky + ;; Creating a sticky Agenda buffer for the first time + (mapc 'make-local-variable org-agenda-local-vars) + (setq-local org-agenda-this-buffer-is-sticky t)) + (t + ;; Creating a non-sticky agenda buffer + (setq-local org-agenda-this-buffer-is-sticky nil))) + (mapc #'make-local-variable agenda-local-vars-to-keep) + (reset-saved agenda-local-vars-to-keep))) (setq org-agenda-undo-list nil org-agenda-pending-undo-list nil org-agenda-bulk-marked-entries nil) @@ -2200,16 +2237,16 @@ The following commands are available: (setq indent-tabs-mode nil) (use-local-map org-agenda-mode-map) (easy-menu-add org-agenda-menu) - (if org-startup-truncated (setq truncate-lines t)) + (when org-startup-truncated (setq truncate-lines t)) (setq-local line-move-visual nil) (add-hook 'post-command-hook 'org-agenda-update-agenda-type nil 'local) (add-hook 'pre-command-hook 'org-unhighlight nil 'local) ;; Make sure properties are removed when copying text (if (boundp 'filter-buffer-substring-functions) (add-hook 'filter-buffer-substring-functions - (lambda (fun start end delete) + (lambda (fun start end delete) (substring-no-properties (funcall fun start end delete))) - nil t) + nil t) ;; Emacs >= 24.4. (add-function :filter-return (local 'filter-buffer-substring-function) #'substring-no-properties)) @@ -2363,9 +2400,10 @@ The following commands are available: (org-defkey org-agenda-mode-map "]" 'org-agenda-manipulate-query-subtract) (org-defkey org-agenda-mode-map "{" 'org-agenda-manipulate-query-add-re) (org-defkey org-agenda-mode-map "}" 'org-agenda-manipulate-query-subtract-re) -(org-defkey org-agenda-mode-map "/" 'org-agenda-filter-by-tag) +(org-defkey org-agenda-mode-map "\\" 'org-agenda-filter-by-tag) (org-defkey org-agenda-mode-map "_" 'org-agenda-filter-by-effort) (org-defkey org-agenda-mode-map "=" 'org-agenda-filter-by-regexp) +(org-defkey org-agenda-mode-map "/" 'org-agenda-filter) (org-defkey org-agenda-mode-map "|" 'org-agenda-filter-remove-all) (org-defkey org-agenda-mode-map "~" 'org-agenda-limit-interactively) (org-defkey org-agenda-mode-map "<" 'org-agenda-filter-by-category) @@ -2375,6 +2413,7 @@ The following commands are available: (define-key org-agenda-mode-map "?" 'org-agenda-show-the-flagging-note) (org-defkey org-agenda-mode-map "\C-c\C-x\C-mg" 'org-mobile-pull) (org-defkey org-agenda-mode-map "\C-c\C-x\C-mp" 'org-mobile-push) +(org-defkey org-agenda-mode-map "\C-c\C-xI" 'org-info-find-node) (org-defkey org-agenda-mode-map [mouse-2] 'org-agenda-goto-mouse) (org-defkey org-agenda-mode-map [mouse-3] 'org-agenda-show-mouse) @@ -2445,8 +2484,20 @@ The following commands are available: :keys "v A"] "--" ["Remove Restriction" org-agenda-remove-restriction-lock org-agenda-restrict]) - ["Write view to file" org-agenda-write t] + ("Filter current view" + ["with generic interface" org-agenda-filter t] + "--" + ["by category at cursor" org-agenda-filter-by-category t] + ["by tag" org-agenda-filter-by-tag t] + ["by effort" org-agenda-filter-by-effort t] + ["by regexp" org-agenda-filter-by-regexp t] + ["by top-level headline" org-agenda-filter-by-top-headline t] + "--" + ["Remove all filtering" org-agenda-filter-remove-all t] + "--" + ["limit" org-agenda-limit-interactively t]) ["Rebuild buffer" org-agenda-redo t] + ["Write view to file" org-agenda-write t] ["Save all Org buffers" org-save-all-org-buffers t] "--" ["Show original entry" org-agenda-show t] @@ -2551,30 +2602,30 @@ that have been changed along." (interactive) (or org-agenda-allow-remote-undo (user-error "Check the variable `org-agenda-allow-remote-undo' to activate remote undo")) - (if (not (eq this-command last-command)) - (setq org-agenda-undo-has-started-in nil - org-agenda-pending-undo-list org-agenda-undo-list)) - (if (not org-agenda-pending-undo-list) - (user-error "No further undo information")) + (when (not (eq this-command last-command)) + (setq org-agenda-undo-has-started-in nil + org-agenda-pending-undo-list org-agenda-undo-list)) + (when (not org-agenda-pending-undo-list) + (user-error "No further undo information")) (let* ((entry (pop org-agenda-pending-undo-list)) buf line cmd rembuf) (setq cmd (pop entry) line (pop entry)) (setq rembuf (nth 2 entry)) (org-with-remote-undo rembuf (while (bufferp (setq buf (pop entry))) - (if (pop entry) - (with-current-buffer buf - (let ((last-undo-buffer buf) - (inhibit-read-only t)) - (unless (memq buf org-agenda-undo-has-started-in) - (push buf org-agenda-undo-has-started-in) - (make-local-variable 'pending-undo-list) - (undo-start)) - (while (and pending-undo-list - (listp pending-undo-list) - (not (car pending-undo-list))) - (pop pending-undo-list)) - (undo-more 1)))))) + (when (pop entry) + (with-current-buffer buf + (let ((last-undo-buffer buf) + (inhibit-read-only t)) + (unless (memq buf org-agenda-undo-has-started-in) + (push buf org-agenda-undo-has-started-in) + (make-local-variable 'pending-undo-list) + (undo-start)) + (while (and pending-undo-list + (listp pending-undo-list) + (not (car pending-undo-list))) + (pop pending-undo-list)) + (undo-more 1)))))) (org-goto-line line) (message "`%s' undone (buffer %s)" cmd (buffer-name rembuf)))) @@ -2797,9 +2848,9 @@ Pressing `<' twice means to restrict to the current subtree or region ;; If we have sticky agenda buffers, set a name for the buffer, ;; depending on the invoking keys. The user may still set this ;; as a command option, which will overwrite what we do here. - (if org-agenda-sticky - (setq org-agenda-buffer-name - (format "*Org Agenda(%s)*" org-keys))) + (when org-agenda-sticky + (setq org-agenda-buffer-name + (format "*Org Agenda(%s)*" org-keys))) ;; Establish the restriction, if any (when (and (not org-agenda-overriding-restriction) restriction) (put 'org-agenda-files 'org-restrict (list bfn)) @@ -2814,7 +2865,13 @@ Pressing `<' twice means to restrict to the current subtree or region (org-back-to-heading t) (move-marker org-agenda-restrict-begin (point)) (move-marker org-agenda-restrict-end - (progn (org-end-of-subtree t))))))) + (progn (org-end-of-subtree t))))) + ((and (eq restriction 'buffer) + (or (< 1 (point-min)) + (< (point-max) (1+ (buffer-size))))) + (setq org-agenda-restrict (current-buffer)) + (move-marker org-agenda-restrict-begin (point-min)) + (move-marker org-agenda-restrict-end (point-max))))) ;; For example the todo list should not need it (but does...) (cond @@ -2823,10 +2880,10 @@ Pressing `<' twice means to restrict to the current subtree or region (progn (setq type (nth 2 entry) org-match (eval (nth 3 entry)) lprops (nth 4 entry)) - (if org-agenda-sticky - (setq org-agenda-buffer-name - (or (and (stringp org-match) (format "*Org Agenda(%s:%s)*" org-keys org-match)) - (format "*Org Agenda(%s)*" org-keys)))) + (when org-agenda-sticky + (setq org-agenda-buffer-name + (or (and (stringp org-match) (format "*Org Agenda(%s:%s)*" org-keys org-match)) + (format "*Org Agenda(%s)*" org-keys)))) (put 'org-agenda-redo-command 'org-lprops lprops) (cond ((eq type 'agenda) @@ -2884,10 +2941,10 @@ Pressing `<' twice means to restrict to the current subtree or region (when note (message "FLAGGING-NOTE ([?] for more info): %s" (org-add-props - (replace-regexp-in-string - "\\\\n" "//" - (copy-sequence note)) - nil 'face 'org-warning)))))) + (replace-regexp-in-string + "\\\\n" "//" + (copy-sequence note)) + nil 'face 'org-warning)))))) t t)) ((equal org-keys "#") (call-interactively 'org-agenda-list-stuck-projects)) ((equal org-keys "/") (call-interactively 'org-occur-in-agenda-files)) @@ -3000,19 +3057,18 @@ s Search for keywords M Like m, but only TODO entries (symbol-name type) "Lambda expression")) (t "???")))) - (if org-agenda-menu-show-matcher - (setq line - (concat line ": " - (cond - ((stringp match) - (setq match (copy-sequence match)) - (org-add-props match nil 'face 'org-warning)) - ((listp type) - (format "set of %d commands" (length type)))))) - (if (org-string-nw-p match) - (add-text-properties - 0 (length line) (list 'help-echo - (concat "Matcher: " match)) line))) + (cond + ((not (org-string-nw-p match)) nil) + (org-agenda-menu-show-matcher + (setq line + (concat line ": " + (cond + ((stringp match) + (propertize match 'face 'org-warning)) + ((listp type) + (format "set of %d commands" (length type))))))) + (t + (org-add-props line nil 'help-echo (concat "Matcher: " match)))) (push line lines))) (setq lines (nreverse lines)) (when prefixes @@ -3048,21 +3104,47 @@ s Search for keywords M Like m, but only TODO entries ;; Make the window the right size (goto-char (point-min)) (if second-time - (if (not (pos-visible-in-window-p (point-max))) - (org-fit-window-to-buffer)) + (when (not (pos-visible-in-window-p (point-max))) + (org-fit-window-to-buffer)) (setq second-time t) (org-fit-window-to-buffer)) + ;; Hint to navigation if window too small for all information + (setq header-line-format + (when (not (pos-visible-in-window-p (point-max))) + "Use SPC, DEL, C-n or C-p to navigate.")) + ;; Ask for selection - (message "Press key for agenda command%s:" - (if (or restrict-ok org-agenda-overriding-restriction) - (if org-agenda-overriding-restriction - " (restriction lock active)" - (if restriction - (format " (restricted to %s)" restriction) - " (unrestricted)")) - "")) - (setq c (read-char-exclusive)) + (cl-loop + do (progn + (message "Press key for agenda command%s:" + (if (or restrict-ok org-agenda-overriding-restriction) + (if org-agenda-overriding-restriction + " (restriction lock active)" + (if restriction + (format " (restricted to %s)" restriction) + " (unrestricted)")) + "")) + (setq c (read-char-exclusive))) + until (not (memq c '(14 16 ?\s ?\d))) + do (cl-case c + (14 (if (not (pos-visible-in-window-p (point-max))) + (ignore-errors (scroll-up 1)) + (message "End of buffer") + (sit-for 1))) + (16 (if (not (pos-visible-in-window-p (point-min))) + (ignore-errors (scroll-down 1)) + (message "Beginning of buffer") + (sit-for 1))) + (?\s (if (not (pos-visible-in-window-p (point-max))) + (scroll-up nil) + (message "End of buffer") + (sit-for 1))) + (?\d (if (not (pos-visible-in-window-p (point-min))) + (scroll-down nil) + (message "Beginning of buffer") + (sit-for 1))))) + (message "") (cond ((assoc (char-to-string c) custom) @@ -3235,7 +3317,7 @@ todo The todo keyword, if any tags All tags including inherited ones, separated by colons date The relevant date, like 2007-2-14 time The time, like 15:00-16:50 -extra Sting with extra planning info +extra String with extra planning info priority-l The priority letter if any was given priority-n The computed numerical priority agenda-day The day in the agenda where this is listed" @@ -3245,11 +3327,9 @@ agenda-day The day in the agenda where this is listed" (org-tags-view nil cmd-key) (org-agenda nil cmd-key))) (set-buffer org-agenda-buffer-name) - (let* ((lines (org-split-string (buffer-string) "\n")) - line) - (while (setq line (pop lines)) - (catch 'next - (if (not (get-text-property 0 'org-category line)) (throw 'next nil)) + (let ((lines (org-split-string (buffer-string) "\n"))) + (dolist (line lines) + (when (get-text-property 0 'org-category line) (setq org-agenda-info (org-fix-agenda-info (text-properties-at 0 line))) (princ @@ -3266,14 +3346,14 @@ This ensures the export commands can easily use it." (when (setq tmp (plist-get props 'tags)) (setq props (plist-put props 'tags (mapconcat 'identity tmp ":")))) (when (setq tmp (plist-get props 'date)) - (if (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp))) + (when (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp))) (let ((calendar-date-display-form '(year "-" month "-" day))) '((format "%4d, %9s %2s, %4s" dayname monthname day year)) (setq tmp (calendar-date-string tmp))) (setq props (plist-put props 'date tmp))) (when (setq tmp (plist-get props 'day)) - (if (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp))) + (when (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp))) (let ((calendar-date-display-form '(year "-" month "-" day))) (setq tmp (calendar-date-string tmp))) (setq props (plist-put props 'day tmp)) @@ -3513,7 +3593,7 @@ removed from the entry content. Currently only `planning' is allowed here." (add-text-properties (match-beginning 0) (match-end 0) '(face org-link)))) (goto-char (point-min)) - (while (re-search-forward org-bracket-link-regexp (point-max) t) + (while (re-search-forward org-link-bracket-re (point-max) t) (set-text-properties (match-beginning 0) (match-end 0) nil)) (goto-char (point-min)) @@ -3536,15 +3616,15 @@ removed from the entry content. Currently only `planning' is allowed here." (replace-match ""))))) (goto-char (point-max)) (skip-chars-backward " \t\n") - (if (looking-at "[ \t\n]+\\'") (replace-match "")) + (when (looking-at "[ \t\n]+\\'") (replace-match "")) ;; find and remove min common indentation (goto-char (point-min)) (untabify (point-min) (point-max)) - (setq ind (org-get-indentation)) + (setq ind (current-indentation)) (while (not (eobp)) (unless (looking-at "[ \t]*$") - (setq ind (min ind (org-get-indentation)))) + (setq ind (min ind (current-indentation)))) (beginning-of-line 2)) (goto-char (point-min)) (while (not (eobp)) @@ -3586,6 +3666,11 @@ removed from the entry content. Currently only `planning' is allowed here." (defvar org-agenda-regexp-filter nil) (defvar org-agenda-effort-filter nil) (defvar org-agenda-top-headline-filter nil) + +(defvar org-agenda-represented-categories nil + "Cache for the list of all categories in the agenda.") +(defvar org-agenda-represented-tags nil + "Cache for the list of all categories in the agenda.") (defvar org-agenda-tag-filter-preset nil "A preset of the tags filter used for secondary agenda filtering. This must be a list of strings, each string must be a single tag preceded @@ -3596,6 +3681,20 @@ the entire agenda view. In a block agenda, it will not work reliably to define a filter for one of the individual blocks. You need to set it in the global options and expect it to be applied to the entire view.") +(defconst org-agenda-filter-variables + '((category . org-agenda-category-filter) + (tag . org-agenda-tag-filter) + (effort . org-agenda-effort-filter) + (regexp . org-agenda-regexp-filter)) + "Alist of filter types and associated variables") +(defun org-agenda-filter-any () + "Is any filter active?" + (let ((form (cons 'or (mapcar (lambda (x) + (if (or (symbol-value (cdr x)) + (get :preset-filter x)) + t nil)) + org-agenda-filter-variables)))) + (eval form))) (defvar org-agenda-category-filter-preset nil "A preset of the category filter used for secondary agenda filtering. This must be a list of strings, each string must be a single category @@ -3681,18 +3780,19 @@ FILTER-ALIST is an alist of filters we need to apply when (or wconf org-agenda-pre-window-conf)))) (defun org-agenda-prepare (&optional name) - (let ((filter-alist (if org-agenda-persistent-filter - (with-current-buffer - (get-buffer-create org-agenda-buffer-name) - (list `(tag . ,org-agenda-tag-filter) - `(re . ,org-agenda-regexp-filter) - `(effort . ,org-agenda-effort-filter) - `(cat . ,org-agenda-category-filter)))))) + (let ((filter-alist (when org-agenda-persistent-filter + (with-current-buffer + (get-buffer-create org-agenda-buffer-name) + `((tag . ,org-agenda-tag-filter) + (re . ,org-agenda-regexp-filter) + (effort . ,org-agenda-effort-filter) + (cat . ,org-agenda-category-filter)))))) (if (org-agenda-use-sticky-p) (progn (put 'org-agenda-tag-filter :preset-filter nil) (put 'org-agenda-category-filter :preset-filter nil) (put 'org-agenda-regexp-filter :preset-filter nil) + (put 'org-agenda-effort-filter :preset-filter nil) ;; Popup existing buffer (org-agenda-prepare-window (get-buffer org-agenda-buffer-name) filter-alist) @@ -3743,7 +3843,8 @@ FILTER-ALIST is an alist of filters we need to apply when (setq-local org-agenda-name name))) (setq buffer-read-only nil)))) -(defvar org-agenda-overriding-columns-format) ; From org-colview.el +(defvar org-overriding-columns-format) +(defvar org-local-columns-format) (defun org-agenda-finalize () "Finishing touch for the agenda buffer, called just before displaying it." (unless org-agenda-multi @@ -3758,13 +3859,11 @@ FILTER-ALIST is an alist of filters we need to apply when (org-agenda-align-tags)) (unless org-agenda-with-colors (remove-text-properties (point-min) (point-max) '(face nil))) - (if (and (boundp 'org-agenda-overriding-columns-format) - org-agenda-overriding-columns-format) - (setq-local org-agenda-overriding-columns-format - org-agenda-overriding-columns-format)) - (if (and (boundp 'org-agenda-view-columns-initially) - org-agenda-view-columns-initially) - (org-agenda-columns)) + (when (bound-and-true-p org-overriding-columns-format) + (setq-local org-local-columns-format + org-overriding-columns-format)) + (when org-agenda-view-columns-initially + (org-agenda-columns)) (when org-agenda-fontify-priorities (org-agenda-fontify-priorities)) (when (and org-agenda-dim-blocked-tasks org-blocker-hook) @@ -3773,9 +3872,9 @@ FILTER-ALIST is an alist of filters we need to apply when (when org-agenda-entry-text-mode (org-agenda-entry-text-hide) (org-agenda-entry-text-show)) - (if (and (functionp 'org-habit-insert-consistency-graphs) - (save-excursion (next-single-property-change (point-min) 'org-habit-p))) - (org-habit-insert-consistency-graphs)) + (when (and (featurep 'org-habit) + (save-excursion (next-single-property-change (point-min) 'org-habit-p))) + (org-habit-insert-consistency-graphs)) (setq org-agenda-type (org-get-at-bol 'org-agenda-type)) (unless (or (eq org-agenda-show-inherited-tags 'always) (and (listp org-agenda-show-inherited-tags) @@ -3791,10 +3890,12 @@ FILTER-ALIST is an alist of filters we need to apply when (while (equal (forward-line) 0) (when (setq mrk (get-text-property (point) 'org-hd-marker)) (put-text-property (point-at-bol) (point-at-eol) - 'tags (org-with-point-at mrk - (delete-dups - (mapcar 'downcase (org-get-tags-at)))))))))) + 'tags + (org-with-point-at mrk + (mapcar #'downcase (org-get-tags))))))))) (run-hooks 'org-agenda-finalize-hook) + (setq org-agenda-represented-tags nil + org-agenda-represented-categories nil) (when org-agenda-top-headline-filter (org-agenda-filter-top-headline-apply org-agenda-top-headline-filter)) @@ -3845,15 +3946,15 @@ FILTER-ALIST is an alist of filters we need to apply when (defun org-agenda-unmark-clocking-task () "Unmark the current clocking task." (mapc (lambda (o) - (if (eq (overlay-get o 'type) 'org-agenda-clocking) - (delete-overlay o))) + (when (eq (overlay-get o 'type) 'org-agenda-clocking) + (delete-overlay o))) (overlays-in (point-min) (point-max)))) (defun org-agenda-fontify-priorities () "Make highest priority lines bold, and lowest italic." (interactive) - (mapc (lambda (o) (if (eq (overlay-get o 'org-type) 'org-priority) - (delete-overlay o))) + (mapc (lambda (o) (when (eq (overlay-get o 'org-type) 'org-priority) + (delete-overlay o))) (overlays-in (point-min) (point-max))) (save-excursion (let (b e p ov h l) @@ -4053,12 +4154,11 @@ This check for agenda markers in all agenda buffers currently active." (defun org-agenda-entry-text-hide () "Remove any shown entry context." - (delq nil - (mapcar (lambda (o) - (if (eq (overlay-get o 'org-overlay-type) - 'agenda-entry-content) - (progn (delete-overlay o) t))) - (overlays-in (point-min) (point-max))))) + (mapc (lambda (o) + (when (eq (overlay-get o 'org-overlay-type) + 'agenda-entry-content) + (delete-overlay o))) + (overlays-in (point-min) (point-max)))) (defun org-agenda-get-day-face (date) "Return the face DATE should be displayed with." @@ -4099,28 +4199,31 @@ given in `org-agenda-start-on-weekday'. When WITH-HOUR is non-nil, only include scheduled and deadline items if they have an hour specification like [h]h:mm." (interactive "P") - (if org-agenda-overriding-arguments - (setq arg (car org-agenda-overriding-arguments) - start-day (nth 1 org-agenda-overriding-arguments) - span (nth 2 org-agenda-overriding-arguments))) - (if (and (integerp arg) (> arg 0)) - (setq span arg arg nil)) + (when org-agenda-overriding-arguments + (setq arg (car org-agenda-overriding-arguments) + start-day (nth 1 org-agenda-overriding-arguments) + span (nth 2 org-agenda-overriding-arguments))) + (when (and (integerp arg) (> arg 0)) + (setq span arg arg nil)) + (when (numberp span) + (unless (< 0 span) + (user-error "Agenda creation impossible for this span(=%d days)." span))) (catch 'exit (setq org-agenda-buffer-name (or org-agenda-buffer-tmp-name (and org-agenda-doing-sticky-redo org-agenda-buffer-name) - (if org-agenda-sticky - (cond ((and org-keys (stringp org-match)) - (format "*Org Agenda(%s:%s)*" org-keys org-match)) - (org-keys - (format "*Org Agenda(%s)*" org-keys)) - (t "*Org Agenda(a)*"))) + (when org-agenda-sticky + (cond ((and org-keys (stringp org-match)) + (format "*Org Agenda(%s:%s)*" org-keys org-match)) + (org-keys + (format "*Org Agenda(%s)*" org-keys)) + (t "*Org Agenda(a)*"))) "*Org Agenda*")) (org-agenda-prepare "Day/Week") (setq start-day (or start-day org-agenda-start-day)) - (if (stringp start-day) - ;; Convert to an absolute day number - (setq start-day (time-to-days (org-read-date nil t start-day)))) + (when (stringp start-day) + ;; Convert to an absolute day number + (setq start-day (time-to-days (org-read-date nil t start-day)))) (org-compile-prefix-format 'agenda) (org-set-sorting-strategy 'agenda) (let* ((span (org-agenda-ndays-to-span (or span org-agenda-span))) @@ -4128,8 +4231,8 @@ items if they have an hour specification like [h]h:mm." (sd (or start-day today)) (ndays (org-agenda-span-to-ndays span sd)) (org-agenda-start-on-weekday - (if (or (eq ndays 7) (eq ndays 14)) - org-agenda-start-on-weekday)) + (and (or (eq ndays 7) (eq ndays 14)) + org-agenda-start-on-weekday)) (thefiles (org-agenda-files nil 'ifmode)) (files thefiles) (start (if (or (null org-agenda-start-on-weekday) @@ -4162,28 +4265,27 @@ items if they have an hour specification like [h]h:mm." (w1 (org-days-to-iso-week d1)) (w2 (org-days-to-iso-week d2))) (setq s (point)) - (if org-agenda-overriding-header - (insert (org-add-props (copy-sequence org-agenda-overriding-header) - nil 'face 'org-agenda-structure) "\n") - (insert (org-agenda-span-name span) + (org-agenda--insert-overriding-header + (concat (org-agenda-span-name span) "-agenda" - (if (< (- d2 d1) 350) - (if (= w1 w2) - (format " (W%02d)" w1) - (format " (W%02d-W%02d)" w1 w2)) - "") + (cond ((<= 350 (- d2 d1)) "") + ((= w1 w2) (format " (W%02d)" w1)) + (t (format " (W%02d-W%02d)" w1 w2))) ":\n"))) - (add-text-properties s (1- (point)) (list 'face 'org-agenda-structure - 'org-date-line t)) - (org-agenda-mark-header-line s)) + ;; Add properties if we actually inserted a header. + (when (> (point) s) + (add-text-properties s (1- (point)) + (list 'face 'org-agenda-structure + 'org-date-line t)) + (org-agenda-mark-header-line s))) (while (setq d (pop day-numbers)) (setq date (calendar-gregorian-from-absolute d) s (point)) (if (or (setq todayp (= d today)) (and (not start-pos) (= d sd))) (setq start-pos (point)) - (if (and start-pos (not end-pos)) - (setq end-pos (point)))) + (when (and start-pos (not end-pos)) + (setq end-pos (point)))) (setq files thefiles rtnall nil) (while (setq file (pop files)) @@ -4223,34 +4325,33 @@ items if they have an hour specification like [h]h:mm." file date org-agenda-entry-types))))) (setq rtnall (append rtnall rtn)))) ;; all entries - (if org-agenda-include-diary - (let ((org-agenda-search-headline-for-time t)) - (require 'diary-lib) - (setq rtn (org-get-entries-from-diary date)) - (setq rtnall (append rtnall rtn)))) - (if (or rtnall org-agenda-show-all-dates) - (progn - (setq day-cnt (1+ day-cnt)) - (insert - (if (stringp org-agenda-format-date) - (format-time-string org-agenda-format-date - (org-time-from-absolute date)) - (funcall org-agenda-format-date date)) - "\n") - (put-text-property s (1- (point)) 'face - (org-agenda-get-day-face date)) - (put-text-property s (1- (point)) 'org-date-line t) - (put-text-property s (1- (point)) 'org-agenda-date-header t) - (put-text-property s (1- (point)) 'org-day-cnt day-cnt) - (when todayp - (put-text-property s (1- (point)) 'org-today t)) - (setq rtnall - (org-agenda-add-time-grid-maybe rtnall ndays todayp)) - (if rtnall (insert ;; all entries - (org-agenda-finalize-entries rtnall 'agenda) - "\n")) - (put-text-property s (1- (point)) 'day d) - (put-text-property s (1- (point)) 'org-day-cnt day-cnt)))) + (when org-agenda-include-diary + (let ((org-agenda-search-headline-for-time t)) + (require 'diary-lib) + (setq rtn (org-get-entries-from-diary date)) + (setq rtnall (append rtnall rtn)))) + (when (or rtnall org-agenda-show-all-dates) + (setq day-cnt (1+ day-cnt)) + (insert + (if (stringp org-agenda-format-date) + (format-time-string org-agenda-format-date + (org-time-from-absolute date)) + (funcall org-agenda-format-date date)) + "\n") + (put-text-property s (1- (point)) 'face + (org-agenda-get-day-face date)) + (put-text-property s (1- (point)) 'org-date-line t) + (put-text-property s (1- (point)) 'org-agenda-date-header t) + (put-text-property s (1- (point)) 'org-day-cnt day-cnt) + (when todayp + (put-text-property s (1- (point)) 'org-today t)) + (setq rtnall + (org-agenda-add-time-grid-maybe rtnall ndays todayp)) + (when rtnall (insert ;; all entries + (org-agenda-finalize-entries rtnall 'agenda) + "\n")) + (put-text-property s (1- (point)) 'day d) + (put-text-property s (1- (point)) 'org-day-cnt day-cnt))) (when (and org-agenda-clockreport-mode clocktable-start) (let ((org-agenda-files (org-agenda-files nil 'ifmode)) ;; the above line is to ensure the restricted range! @@ -4264,22 +4365,22 @@ items if they have an hour specification like [h]h:mm." (insert tbl))) (goto-char (point-min)) (or org-agenda-multi (org-agenda-fit-window-to-buffer)) - (unless (and (pos-visible-in-window-p (point-min)) - (pos-visible-in-window-p (point-max))) + (unless (or (not (get-buffer-window)) + (and (pos-visible-in-window-p (point-min)) + (pos-visible-in-window-p (point-max)))) (goto-char (1- (point-max))) (recenter -1) - (if (not (pos-visible-in-window-p (or start-pos 1))) - (progn - (goto-char (or start-pos 1)) - (recenter 1)))) + (when (not (pos-visible-in-window-p (or start-pos 1))) + (goto-char (or start-pos 1)) + (recenter 1))) (goto-char (or start-pos 1)) (add-text-properties (point-min) (point-max) `(org-agenda-type agenda org-last-args (,arg ,start-day ,span) org-redo-cmd ,org-agenda-redo-command org-series-cmd ,org-cmd)) - (if (eq org-agenda-show-log-scoped 'clockcheck) - (org-agenda-show-clocking-issues)) + (when (eq org-agenda-show-log-scoped 'clockcheck) + (org-agenda-show-clocking-issues)) (org-agenda-finalize) (setq buffer-read-only t) (message "")))) @@ -4379,10 +4480,10 @@ This command searches the agenda files, and in addition the files listed in `org-agenda-text-search-extra-files' unless a restriction lock is active." (interactive "P") - (if org-agenda-overriding-arguments - (setq todo-only (car org-agenda-overriding-arguments) - string (nth 1 org-agenda-overriding-arguments) - edit-at (nth 2 org-agenda-overriding-arguments))) + (when org-agenda-overriding-arguments + (setq todo-only (car org-agenda-overriding-arguments) + string (nth 1 org-agenda-overriding-arguments) + edit-at (nth 2 org-agenda-overriding-arguments))) (let* ((props (list 'face nil 'done-face 'org-agenda-done 'org-not-done-regexp org-not-done-regexp @@ -4407,12 +4508,12 @@ is active." (edit-at string)) 'org-agenda-search-history))) (catch 'exit - (if org-agenda-sticky - (setq org-agenda-buffer-name - (if (stringp string) - (format "*Org Agenda(%s:%s)*" - (or org-keys (or (and todo-only "S") "s")) string) - (format "*Org Agenda(%s)*" (or (and todo-only "S") "s"))))) + (when org-agenda-sticky + (setq org-agenda-buffer-name + (if (stringp string) + (format "*Org Agenda(%s:%s)*" + (or org-keys (or (and todo-only "S") "s")) string) + (format "*Org Agenda(%s)*" (or (and todo-only "S") "s"))))) (org-agenda-prepare "SEARCH") (org-compile-prefix-format 'search) (org-set-sorting-strategy 'search) @@ -4430,9 +4531,9 @@ is active." (when (equal (string-to-char words) ?:) (setq full-words t words (substring words 1))) - (if (or org-agenda-search-view-always-boolean - (member (string-to-char words) '(?- ?+ ?\{))) - (setq boolean t)) + (when (or org-agenda-search-view-always-boolean + (member (string-to-char words) '(?- ?+ ?\{))) + (setq boolean t)) (setq words (split-string words)) (let (www w) (while (setq w (pop words)) @@ -4452,12 +4553,12 @@ is active." (when boolean (let (wds w) (while (setq w (pop words)) - (if (or (equal (substring w 0 1) "\"") - (and (> (length w) 1) - (member (substring w 0 1) '("+" "-")) - (equal (substring w 1 2) "\""))) - (while (and words (not (equal (substring w -1) "\""))) - (setq w (concat w " " (pop words))))) + (when (or (equal (substring w 0 1) "\"") + (and (> (length w) 1) + (member (substring w 0 1) '("+" "-")) + (equal (substring w 1 2) "\""))) + (while (and words (not (equal (substring w -1) "\""))) + (setq w (concat w " " (pop words))))) (and (string-match "\\`\\([-+]?\\)\"" w) (setq w (replace-match "\\1" nil nil w))) (and (equal (substring w -1) "\"") (setq w (substring w 0 -1))) @@ -4484,14 +4585,14 @@ is active." (if (not regexps+) (setq regexp org-outline-regexp-bol) (setq regexp (pop regexps+)) - (if hdl-only (setq regexp (concat org-outline-regexp-bol ".*?" - regexp)))) + (when hdl-only (setq regexp (concat org-outline-regexp-bol ".*?" + regexp)))) (setq files (org-agenda-files nil 'ifmode)) ;; Add `org-agenda-text-search-extra-files' unless there is some ;; restriction. - (unless (get 'org-agenda-files 'org-restrict) - (when (eq (car org-agenda-text-search-extra-files) 'agenda-archives) - (pop org-agenda-text-search-extra-files) + (when (eq (car org-agenda-text-search-extra-files) 'agenda-archives) + (pop org-agenda-text-search-extra-files) + (unless (get 'org-agenda-files 'org-restrict) (setq files (org-add-archive-files files)))) ;; Uniquify files. However, let `org-check-agenda-file' handle ;; non-existent ones. @@ -4509,10 +4610,10 @@ is active." (setq buffer (if (file-exists-p file) (org-get-agenda-file-buffer file) (error "No such file %s" file))) - (if (not buffer) - ;; If file does not exist, make sure an error message is sent - (setq rtn (list (format "ORG-AGENDA-ERROR: No such org-file %s" - file)))) + (unless buffer + ;; If file does not exist, make sure an error message is sent + (setq rtn (list (format "ORG-AGENDA-ERROR: No such org-file %s" + file)))) (with-current-buffer buffer (with-syntax-table (org-search-syntax-table) (unless (derived-mode-p 'org-mode) @@ -4555,12 +4656,12 @@ is active." (point-at-bol) (if hdl-only (point-at-eol) end))) (mapc (lambda (wr) (when (string-match wr str) - (goto-char (1- end)) - (throw :skip t))) + (goto-char (1- end)) + (throw :skip t))) regexps-) (mapc (lambda (wr) (unless (string-match wr str) - (goto-char (1- end)) - (throw :skip t))) + (goto-char (1- end)) + (throw :skip t))) (if todo-only (cons (concat "^\\*+[ \t]+" org-not-done-regexp) @@ -4577,7 +4678,7 @@ is active." (and (eq org-agenda-show-inherited-tags t) (or (eq org-agenda-use-tag-inheritance t) (memq 'todo org-agenda-use-tag-inheritance)))) - tags (org-get-tags-at nil (not inherited-tags)) + tags (org-get-tags nil (not inherited-tags)) txt (org-agenda-format-item "" (buffer-substring-no-properties @@ -4594,25 +4695,25 @@ is active." (goto-char (1- end)))))))))) (setq rtn (nreverse ee)) (setq rtnall (append rtnall rtn))) - (if org-agenda-overriding-header - (insert (org-add-props (copy-sequence org-agenda-overriding-header) - nil 'face 'org-agenda-structure) "\n") - (insert "Search words: ") - (add-text-properties (point-min) (1- (point)) - (list 'face 'org-agenda-structure)) - (setq pos (point)) - (insert string "\n") - (add-text-properties pos (1- (point)) (list 'face 'org-warning)) - (setq pos (point)) - (unless org-agenda-multi - (insert (substitute-command-keys "\ + (org-agenda--insert-overriding-header + (with-temp-buffer + (insert "Search words: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure)) + (setq pos (point)) + (insert string "\n") + (add-text-properties pos (1- (point)) (list 'face 'org-warning)) + (setq pos (point)) + (unless org-agenda-multi + (insert (substitute-command-keys "\\<org-agenda-mode-map>\ Press `\\[org-agenda-manipulate-query-add]', \ `\\[org-agenda-manipulate-query-subtract]' to add/sub word, \ `\\[org-agenda-manipulate-query-add-re]', \ `\\[org-agenda-manipulate-query-subtract-re]' to add/sub regexp, \ -`\\[universal-argument] \\[org-agenda-redo]' to edit\n")) - (add-text-properties pos (1- (point)) - (list 'face 'org-agenda-structure)))) +`\\[universal-argument] \\[org-agenda-redo]' for a fresh search\n")) + (add-text-properties pos (1- (point)) + (list 'face 'org-agenda-structure))) + (buffer-string))) (org-agenda-mark-header-line (point-min)) (when rtnall (insert (org-agenda-finalize-entries rtnall 'search) "\n")) @@ -4651,31 +4752,31 @@ the list to these. When using `\\[universal-argument]', you will be prompted for a keyword. A numeric prefix directly selects the Nth keyword in `org-todo-keywords-1'." (interactive "P") - (if org-agenda-overriding-arguments - (setq arg org-agenda-overriding-arguments)) - (if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil)) + (when org-agenda-overriding-arguments + (setq arg org-agenda-overriding-arguments)) + (when (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil)) (let* ((today (org-today)) (date (calendar-gregorian-from-absolute today)) - (kwds org-todo-keywords-for-agenda) (completion-ignore-case t) - (org-select-this-todo-keyword - (if (stringp arg) arg - (and arg (integerp arg) (> arg 0) - (nth (1- arg) kwds)))) - rtn rtnall files file pos) - (when (equal arg '(4)) - (setq org-select-this-todo-keyword - (completing-read "Keyword (or KWD1|K2D2|...): " - (mapcar #'list kwds) nil nil))) - (and (equal 0 arg) (setq org-select-this-todo-keyword nil)) + kwds org-select-this-todo-keyword rtn rtnall files file pos) (catch 'exit - (if org-agenda-sticky - (setq org-agenda-buffer-name - (if (stringp org-select-this-todo-keyword) - (format "*Org Agenda(%s:%s)*" (or org-keys "t") - org-select-this-todo-keyword) - (format "*Org Agenda(%s)*" (or org-keys "t"))))) + (when org-agenda-sticky + (setq org-agenda-buffer-name + (if (stringp org-select-this-todo-keyword) + (format "*Org Agenda(%s:%s)*" (or org-keys "t") + org-select-this-todo-keyword) + (format "*Org Agenda(%s)*" (or org-keys "t"))))) (org-agenda-prepare "TODO") + (setq kwds org-todo-keywords-for-agenda + org-select-this-todo-keyword (if (stringp arg) arg + (and (integerp arg) + (> arg 0) + (nth (1- arg) kwds)))) + (when (equal arg '(4)) + (setq org-select-this-todo-keyword + (completing-read "Keyword (or KWD1|K2D2|...): " + (mapcar #'list kwds) nil nil))) + (and (equal 0 arg) (setq org-select-this-todo-keyword nil)) (org-compile-prefix-format 'todo) (org-set-sorting-strategy 'todo) (setq org-agenda-redo-command @@ -4690,31 +4791,31 @@ for a keyword. A numeric prefix directly selects the Nth keyword in (org-check-agenda-file file) (setq rtn (org-agenda-get-day-entries file date :todo)) (setq rtnall (append rtnall rtn)))) - (if org-agenda-overriding-header - (insert (org-add-props (copy-sequence org-agenda-overriding-header) - nil 'face 'org-agenda-structure) "\n") - (insert "Global list of TODO items of type: ") - (add-text-properties (point-min) (1- (point)) - (list 'face 'org-agenda-structure - 'short-heading - (concat "ToDo: " - (or org-select-this-todo-keyword "ALL")))) - (org-agenda-mark-header-line (point-min)) - (insert (org-agenda-propertize-selected-todo-keywords - org-select-this-todo-keyword)) - (setq pos (point)) - (unless org-agenda-multi - (insert (substitute-command-keys "Available with \ -`N \\[org-agenda-redo]': (0)[ALL]")) - (let ((n 0) s) - (mapc (lambda (x) - (setq s (format "(%d)%s" (setq n (1+ n)) x)) - (if (> (+ (current-column) (string-width s) 1) (frame-width)) - (insert "\n ")) - (insert " " s)) - kwds)) - (insert "\n")) - (add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure))) + (org-agenda--insert-overriding-header + (with-temp-buffer + (insert "Global list of TODO items of type: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure + 'short-heading + (concat "ToDo: " + (or org-select-this-todo-keyword "ALL")))) + (org-agenda-mark-header-line (point-min)) + (insert (org-agenda-propertize-selected-todo-keywords + org-select-this-todo-keyword)) + (setq pos (point)) + (unless org-agenda-multi + (insert (substitute-command-keys "Press \ +\\<org-agenda-mode-map>`N \\[org-agenda-redo]' (e.g. `0 \\[org-agenda-redo]') \ +to search again: (0)[ALL]")) + (let ((n 0)) + (dolist (k kwds) + (let ((s (format "(%d)%s" (cl-incf n) k))) + (when (> (+ (current-column) (string-width s) 1) (window-width)) + (insert "\n ")) + (insert " " s)))) + (insert "\n")) + (add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure)) + (buffer-string))) (org-agenda-mark-header-line (point-min)) (when rtnall (insert (org-agenda-finalize-entries rtnall 'todo) "\n")) @@ -4735,9 +4836,9 @@ for a keyword. A numeric prefix directly selects the Nth keyword in "Show all headlines for all `org-agenda-files' matching a TAGS criterion. The prefix arg TODO-ONLY limits the search to TODO entries." (interactive "P") - (if org-agenda-overriding-arguments - (setq todo-only (car org-agenda-overriding-arguments) - match (nth 1 org-agenda-overriding-arguments))) + (when org-agenda-overriding-arguments + (setq todo-only (car org-agenda-overriding-arguments) + match (nth 1 org-agenda-overriding-arguments))) (let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels) (completion-ignore-case t) @@ -4747,17 +4848,18 @@ The prefix arg TODO-ONLY limits the search to TODO entries." (when (and (stringp match) (not (string-match "\\S-" match))) (setq match nil)) (catch 'exit - (if org-agenda-sticky - (setq org-agenda-buffer-name - (if (stringp match) - (format "*Org Agenda(%s:%s)*" - (or org-keys (or (and todo-only "M") "m")) match) - (format "*Org Agenda(%s)*" (or (and todo-only "M") "m"))))) + ;; TODO: this code is repeated a lot... + (when org-agenda-sticky + (setq org-agenda-buffer-name + (if (stringp match) + (format "*Org Agenda(%s:%s)*" + (or org-keys (or (and todo-only "M") "m")) match) + (format "*Org Agenda(%s)*" (or (and todo-only "M") "m"))))) + (setq matcher (org-make-tags-matcher match)) ;; Prepare agendas (and `org-tag-alist-for-agenda') before ;; expanding tags within `org-make-tags-matcher' (org-agenda-prepare (concat "TAGS " match)) - (setq matcher (org-make-tags-matcher match) - match (car matcher) + (setq match (car matcher) matcher (cdr matcher)) (org-compile-prefix-format 'tags) (org-set-sorting-strategy 'tags) @@ -4792,24 +4894,25 @@ The prefix arg TODO-ONLY limits the search to TODO entries." matcher org--matcher-tags-todo-only)) (setq rtnall (append rtnall rtn)))))))) - (if org-agenda-overriding-header - (insert (org-add-props (copy-sequence org-agenda-overriding-header) - nil 'face 'org-agenda-structure) "\n") - (insert "Headlines with TAGS match: ") - (add-text-properties (point-min) (1- (point)) - (list 'face 'org-agenda-structure - 'short-heading - (concat "Match: " match))) - (setq pos (point)) - (insert match "\n") - (add-text-properties pos (1- (point)) (list 'face 'org-warning)) - (setq pos (point)) - (unless org-agenda-multi - (insert (substitute-command-keys - "Press `\\[universal-argument] \\[org-agenda-redo]' \ -to search again with new search string\n"))) - (add-text-properties pos (1- (point)) - (list 'face 'org-agenda-structure))) + (org-agenda--insert-overriding-header + (with-temp-buffer + (insert "Headlines with TAGS match: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure + 'short-heading + (concat "Match: " match))) + (setq pos (point)) + (insert match "\n") + (add-text-properties pos (1- (point)) (list 'face 'org-warning)) + (setq pos (point)) + (unless org-agenda-multi + (insert (substitute-command-keys + "Press \ +\\<org-agenda-mode-map>`\\[universal-argument] \\[org-agenda-redo]' \ +to search again\n"))) + (add-text-properties pos (1- (point)) + (list 'face 'org-agenda-structure)) + (buffer-string))) (org-agenda-mark-header-line (point-min)) (when rtnall (insert (org-agenda-finalize-entries rtnall 'tags) "\n")) @@ -4833,8 +4936,11 @@ used by user-defined selections using `org-agenda-skip-function'.") (defvar org-agenda-overriding-header nil "When set during agenda, todo and tags searches it replaces the header. -This variable should not be set directly, but custom commands can bind it -in the options section.") +If an empty string, no header will be inserted. If any other +string, it will be inserted as a header. If nil, a header will +be generated automatically according to the command. This +variable should not be set directly, but custom commands can bind +it in the options section.") (defun org-agenda-skip-entry-if (&rest conditions) "Skip entry if any of CONDITIONS is true. @@ -4981,14 +5087,14 @@ of what a project is and how to check if it stuck, customize the variable (format "^\\*+[ \t]+\\(%s\\)\\>" (mapconcat #'identity todo-wds "\\|")))) (tags-re (cond ((null tags) nil) - ((member "*" tags) - (eval-when-compile + ((member "*" tags) org-tag-line-re) + (tags + (let ((other-tags (format "\\(?:%s:\\)*" org-tag-re))) (concat org-outline-regexp-bol - ".*:[[:alnum:]_@#%]+:[ \t]*$"))) - (tags (concat org-outline-regexp-bol - ".*:\\(" - (mapconcat #'identity tags "\\|") - "\\):[[:alnum:]_@#%:]*[ \t]*$")) + ".*?[ \t]:" + other-tags + (regexp-opt tags t) + ":" other-tags "[ \t]*$"))) (t nil))) (re-list (delq nil (list todo-re tags-re gen-re))) (skip-re @@ -5090,23 +5196,10 @@ each date. It also removes lines that contain only whitespace." (while (re-search-forward "^ +\n" nil t) (replace-match "")) (goto-char (point-min)) - (if (re-search-forward "^Org mode dummy\n?" nil t) - (replace-match "")) + (when (re-search-forward "^Org mode dummy\n?" nil t) + (replace-match "")) (run-hooks 'org-agenda-cleanup-fancy-diary-hook)) -;; Make sure entries from the diary have the right text properties. -(eval-after-load "diary-lib" - '(if (boundp 'diary-modify-entry-list-string-function) - ;; We can rely on the hook, nothing to do - nil - ;; Hook not available, must use advice to make this work - (defadvice add-to-diary-list (before org-mark-diary-entry activate) - "Make the position visible." - (if (and org-disable-agenda-to-diary ;; called from org-agenda - (stringp string) - buffer-file-name) - (setq string (org-modify-diary-entry-string string)))))) - (defun org-modify-diary-entry-string (string) "Add text properties to string, allowing Org to act on it." (org-add-props string nil @@ -5184,14 +5277,14 @@ function from a program - use `org-agenda-get-day-entries' instead." (setq org-diary-last-run-time time) ;; If this is called during org-agenda, don't return any entries to ;; the calendar. Org Agenda will list these entries itself. - (if org-disable-agenda-to-diary (setq files nil)) + (when org-disable-agenda-to-diary (setq files nil)) (while (setq file (pop files)) (setq rtn (apply 'org-agenda-get-day-entries file date args)) (setq results (append results rtn))) (when results (setq results (mapcar (lambda (i) (replace-regexp-in-string - org-bracket-link-regexp "\\3" i)) results)) + org-link-bracket-re "\\2" i)) results)) (concat (org-agenda-finalize-entries results) "\n")))) ;;; Agenda entry finders @@ -5366,7 +5459,7 @@ and the timestamp type relevant for the sorting strategy in (and (eq org-agenda-show-inherited-tags t) (or (eq org-agenda-use-tag-inheritance t) (memq 'todo org-agenda-use-tag-inheritance)))) - tags (org-get-tags-at nil (not inherited-tags)) + tags (org-get-tags nil (not inherited-tags)) level (make-string (org-reduced-level (org-outline-level)) ? ) txt (org-agenda-format-item "" txt level category tags t) priority (1+ (org-get-priority txt))) @@ -5421,7 +5514,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines', (and org-agenda-todo-ignore-deadlines (re-search-forward org-deadline-time-regexp end t) (cond - ((memq org-agenda-todo-ignore-deadlines '(t all)) t) + ((eq org-agenda-todo-ignore-deadlines 'all) t) ((eq org-agenda-todo-ignore-deadlines 'far) (not (org-deadline-close-p (match-string 1)))) ((eq org-agenda-todo-ignore-deadlines 'future) @@ -5576,7 +5669,7 @@ displayed in agenda view." (or (eq org-agenda-use-tag-inheritance t) (memq 'agenda org-agenda-use-tag-inheritance))))) - (tags (org-get-tags-at nil (not inherited-tags))) + (tags (org-get-tags nil (not inherited-tags))) (level (make-string (org-reduced-level (org-outline-level)) ?\s)) (head (and (looking-at "\\*+[ \t]+\\(.*\\)") @@ -5640,7 +5733,7 @@ displayed in agenda view." (and (eq org-agenda-show-inherited-tags t) (or (eq org-agenda-use-tag-inheritance t) (memq 'agenda org-agenda-use-tag-inheritance)))) - tags (org-get-tags-at nil (not inherited-tags)) + tags (org-get-tags nil (not inherited-tags)) todo-state (org-get-todo-state) warntime (get-text-property (point) 'org-appt-warntime) extra nil) @@ -5728,10 +5821,10 @@ then those holidays will be skipped." (parts (delq nil (list - (if (memq 'closed items) (concat "\\<" org-closed-string)) - (if (memq 'clock items) (concat "\\<" org-clock-string)) - (if (memq 'state items) - (format "- State \"%s\".*?" org-todo-regexp))))) + (when (memq 'closed items) (concat "\\<" org-closed-string)) + (when (memq 'clock items) (concat "\\<" org-clock-string)) + (when (memq 'state items) + (format "- +State \"%s\".*?" org-todo-regexp))))) (parts-re (if parts (mapconcat 'identity parts "\\|") (error "`org-agenda-log-mode-items' is empty"))) (regexp (concat @@ -5745,7 +5838,7 @@ then those holidays will be skipped." 0 0 0 (nth 1 date) (car date) (nth 2 date))) 1 11)))) (org-agenda-search-headline-for-time nil) - marker hdmarker priority category level tags closedp + marker hdmarker priority category level tags closedp type statep clockp state ee txt extra timestr rest clocked inherited-tags) (goto-char (point-min)) (while (re-search-forward regexp nil t) @@ -5790,7 +5883,7 @@ then those holidays will be skipped." (and (eq org-agenda-show-inherited-tags t) (or (eq org-agenda-use-tag-inheritance t) (memq 'todo org-agenda-use-tag-inheritance)))) - tags (org-get-tags-at nil (not inherited-tags)) + tags (org-get-tags nil (not inherited-tags)) level (make-string (org-reduced-level (org-outline-level)) ? )) (looking-at "\\*+[ \t]+\\([^\r\n]+\\)") (setq txt (match-string 1)) @@ -5805,11 +5898,14 @@ then those holidays will be skipped." (statep (concat "State: (" state ")")) (t (concat "Clocked: (" clocked ")"))) txt level category tags timestr))) + (setq type (cond (closedp "closed") + (statep "state") + (t "clock"))) (setq priority 100000) (org-add-props txt props 'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done 'priority priority 'level level - 'type "closed" 'date date + 'type type 'date date 'undone-face 'org-warning 'done-face 'org-agenda-done) (push txt ee)) (goto-char (point-at-eol)))) @@ -5854,7 +5950,14 @@ See also the user option `org-agenda-clock-consistency-checks'." (error "No valid Clock line") (throw 'next t)) (unless (match-end 3) - (setq issue "No end time" + (setq issue + (format + "No end time: (%s)" + (org-duration-from-minutes + (floor + (- (float-time (org-current-time)) + (float-time (org-time-string-to-time (match-string 1)))) + 60))) face (or (plist-get pl :no-end-time-face) face)) (throw 'next t)) (setq ts (match-string 1) @@ -5904,15 +6007,15 @@ See also the user option `org-agenda-clock-consistency-checks'." (unless ok-list ;; there are no OK times for gaps... (throw 'exit nil)) - (if (> (- (/ t2 36000) (/ t1 36000)) 24) - ;; This is more than 24 hours, so it is OK. - ;; because we have at least one OK time, that must be in the - ;; 24 hour interval. - (throw 'exit t)) + (when (> (- (/ t2 36000) (/ t1 36000)) 24) + ;; This is more than 24 hours, so it is OK. + ;; because we have at least one OK time, that must be in the + ;; 24 hour interval. + (throw 'exit t)) ;; We have a shorter gap. ;; Now we have to get the minute of the day when these times are - (let* ((t1dec (decode-time t1)) - (t2dec (decode-time t2)) + (let* ((t1dec (org-decode-time t1)) + (t2dec (org-decode-time t2)) ;; compute the minute on the day (min1 (+ (nth 1 t1dec) (* 60 (nth 2 t1dec)))) (min2 (+ (nth 1 t2dec) (* 60 (nth 2 t2dec))))) @@ -5923,7 +6026,7 @@ See also the user option `org-agenda-clock-consistency-checks'." ;; Now check if any of the OK times is in the gap (mapc (lambda (x) ;; Wrap the time to after midnight if necessary - (if (< x min1) (setq x (+ x 1440))) + (when (< x min1) (setq x (+ x 1440))) ;; Check if in interval (and (<= min1 x) (>= min2 x) (throw 'exit t))) ok-list) @@ -6004,10 +6107,7 @@ specification like [h]h:mm." org-deadline-warning-days)) ;; Set pre-warning to deadline. (t 0)))) - (wdays (if suppress-prewarning - (let ((org-deadline-warning-days suppress-prewarning)) - (org-get-wdays s)) - (org-get-wdays s)))) + (wdays (or suppress-prewarning (org-get-wdays s)))) (cond ;; Only display deadlines at their base date, at future ;; repeat occurrences or in today agenda. @@ -6039,7 +6139,7 @@ specification like [h]h:mm." (or (eq org-agenda-use-tag-inheritance t) (memq 'agenda org-agenda-use-tag-inheritance))))) - (tags (org-get-tags-at nil (not inherited-tags))) + (tags (org-get-tags nil (not inherited-tags))) (time (cond ;; No time of day designation if it is only @@ -6154,6 +6254,7 @@ scheduled items with an hour specification like [h]h:mm." (diff (- current schedule)) (warntime (get-text-property (point) 'org-appt-warntime)) (pastschedp (< schedule today)) + (futureschedp (> schedule today)) (habitp (and (fboundp 'org-is-habit-p) (org-is-habit-p))) (suppress-delay (let ((deadline (and org-agenda-skip-scheduled-delay-if-deadline @@ -6191,7 +6292,8 @@ scheduled items with an hour specification like [h]h:mm." habitp (bound-and-true-p org-habit-show-all-today)) (when (or (and (> ddays 0) (< diff ddays)) - (> diff org-scheduled-past-days) + (> diff (or (and habitp org-habit-scheduled-past-days) + org-scheduled-past-days)) (> schedule current) (and (/= current schedule) (/= current today) @@ -6239,15 +6341,23 @@ scheduled items with an hour specification like [h]h:mm." (or (eq org-agenda-use-tag-inheritance t) (memq 'agenda org-agenda-use-tag-inheritance))))) - (tags (org-get-tags-at nil (not inherited-tags))) + (tags (org-get-tags nil (not inherited-tags))) (level (make-string (org-reduced-level (org-outline-level)) ?\s)) (head (buffer-substring (point) (line-end-position))) (time (cond - ;; No time of day designation if it is only - ;; a reminder. - ((and (/= current schedule) (/= current repeat)) nil) + ;; No time of day designation if it is only a + ;; reminder, except for habits, which always show + ;; the time of day. Habits are an exception + ;; because if there is a time of day, that is + ;; interpreted to mean they should usually happen + ;; then, even if doing the habit was missed. + ((and + (not habitp) + (/= current schedule) + (/= current repeat)) + nil) ((string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s) (concat (substring s (match-beginning 1)) " ")) (t 'time))) @@ -6261,6 +6371,8 @@ scheduled items with an hour specification like [h]h:mm." head level category tags time nil habitp)) (face (cond ((and (not habitp) pastschedp) 'org-scheduled-previously) + ((and habitp futureschedp) + 'org-agenda-done) (todayp 'org-scheduled-today) (t 'org-scheduled))) (habitp (and habitp (org-habit-parse-todo)))) @@ -6324,59 +6436,59 @@ scheduled items with an hour specification like [h]h:mm." pos (current-buffer) (error-message-string err)))))) - (if (and (> (- d0 d1) -1) (> (- d2 d0) -1)) - ;; Only allow days between the limits, because the normal - ;; date stamps will catch the limits. - (save-excursion - (setq todo-state (org-get-todo-state)) - (setq donep (member todo-state org-done-keywords)) - (if (and donep org-agenda-skip-timestamp-if-done) - (throw :skip t)) - (setq marker (org-agenda-new-marker (point)) - category (org-get-category)) - (if (not (re-search-backward org-outline-regexp-bol nil t)) - (throw :skip nil) - (goto-char (match-beginning 0)) - (setq hdmarker (org-agenda-new-marker (point)) - inherited-tags - (or (eq org-agenda-show-inherited-tags 'always) - (and (listp org-agenda-show-inherited-tags) - (memq 'agenda org-agenda-show-inherited-tags)) - (and (eq org-agenda-show-inherited-tags t) - (or (eq org-agenda-use-tag-inheritance t) - (memq 'agenda org-agenda-use-tag-inheritance)))) - - tags (org-get-tags-at nil (not inherited-tags))) - (setq level (make-string (org-reduced-level (org-outline-level)) ? )) - (looking-at "\\*+[ \t]+\\(.*\\)") - (setq head (match-string 1)) - (let ((remove-re - (if org-agenda-remove-timeranges-from-blocks - (concat - "<" (regexp-quote s1) ".*?>" - "--" - "<" (regexp-quote s2) ".*?>") - nil))) - (setq txt (org-agenda-format-item - (format - (nth (if (= d1 d2) 0 1) - org-agenda-timerange-leaders) - (1+ (- d0 d1)) (1+ (- d2 d1))) - head level category tags - (cond ((and (= d1 d0) (= d2 d0)) - (concat "<" start-time ">--<" end-time ">")) - ((= d1 d0) - (concat "<" start-time ">")) - ((= d2 d0) - (concat "<" end-time ">"))) - remove-re)))) - (org-add-props txt props - 'org-marker marker 'org-hd-marker hdmarker - 'type "block" 'date date - 'level level - 'todo-state todo-state - 'priority (org-get-priority txt)) - (push txt ee)))) + (when (and (> (- d0 d1) -1) (> (- d2 d0) -1)) + ;; Only allow days between the limits, because the normal + ;; date stamps will catch the limits. + (save-excursion + (setq todo-state (org-get-todo-state)) + (setq donep (member todo-state org-done-keywords)) + (when (and donep org-agenda-skip-timestamp-if-done) + (throw :skip t)) + (setq marker (org-agenda-new-marker (point)) + category (org-get-category)) + (if (not (re-search-backward org-outline-regexp-bol nil t)) + (throw :skip nil) + (goto-char (match-beginning 0)) + (setq hdmarker (org-agenda-new-marker (point)) + inherited-tags + (or (eq org-agenda-show-inherited-tags 'always) + (and (listp org-agenda-show-inherited-tags) + (memq 'agenda org-agenda-show-inherited-tags)) + (and (eq org-agenda-show-inherited-tags t) + (or (eq org-agenda-use-tag-inheritance t) + (memq 'agenda org-agenda-use-tag-inheritance)))) + + tags (org-get-tags nil (not inherited-tags))) + (setq level (make-string (org-reduced-level (org-outline-level)) ? )) + (looking-at "\\*+[ \t]+\\(.*\\)") + (setq head (match-string 1)) + (let ((remove-re + (if org-agenda-remove-timeranges-from-blocks + (concat + "<" (regexp-quote s1) ".*?>" + "--" + "<" (regexp-quote s2) ".*?>") + nil))) + (setq txt (org-agenda-format-item + (format + (nth (if (= d1 d2) 0 1) + org-agenda-timerange-leaders) + (1+ (- d0 d1)) (1+ (- d2 d1))) + head level category tags + (cond ((and (= d1 d0) (= d2 d0)) + (concat "<" start-time ">--<" end-time ">")) + ((= d1 d0) + (concat "<" start-time ">")) + ((= d2 d0) + (concat "<" end-time ">"))) + remove-re)))) + (org-add-props txt props + 'org-marker marker 'org-hd-marker hdmarker + 'type "block" 'date date + 'level level + 'todo-state todo-state + 'priority (org-get-priority txt)) + (push txt ee)))) (goto-char pos))) ;; Sort the entries by expiration date. (nreverse ee))) @@ -6460,9 +6572,9 @@ Any match of REMOVE-RE will be removed from TXT." (tag (if tags (nth (1- (length tags)) tags) "")) (time-grid-trailing-characters (nth 2 org-agenda-time-grid)) time - (ts (if dotime (concat - (if (stringp dotime) dotime "") - (and org-agenda-search-headline-for-time txt)))) + (ts (when dotime (concat + (if (stringp dotime) dotime "") + (and org-agenda-search-headline-for-time txt)))) (time-of-day (and dotime (org-get-time-of-day ts))) stamp plain s0 s1 s2 rtn srp l duration breadcrumbs) @@ -6480,17 +6592,17 @@ Any match of REMOVE-RE will be removed from TXT." ;; If the times are in TXT (not in DOTIMES), and the prefix will list ;; them, we might want to remove them there to avoid duplication. ;; The user can turn this off with a variable. - (if (and org-prefix-has-time - org-agenda-remove-times-when-in-prefix (or stamp plain) - (string-match (concat (regexp-quote s0) " *") txt) - (not (equal ?\] (string-to-char (substring txt (match-end 0))))) - (if (eq org-agenda-remove-times-when-in-prefix 'beg) - (= (match-beginning 0) 0) - t)) - (setq txt (replace-match "" nil nil txt)))) + (when (and org-prefix-has-time + org-agenda-remove-times-when-in-prefix (or stamp plain) + (string-match (concat (regexp-quote s0) " *") txt) + (not (equal ?\] (string-to-char (substring txt (match-end 0))))) + (if (eq org-agenda-remove-times-when-in-prefix 'beg) + (= (match-beginning 0) 0) + t)) + (setq txt (replace-match "" nil nil txt)))) ;; Normalize the time(s) to 24 hour - (if s1 (setq s1 (org-get-time-of-day s1 'string t))) - (if s2 (setq s2 (org-get-time-of-day s2 'string t))) + (when s1 (setq s1 (org-get-time-of-day s1 'string t))) + (when s2 (setq s2 (org-get-time-of-day s2 'string t))) ;; Try to set s2 if s1 and ;; `org-agenda-default-appointment-duration' are set @@ -6506,7 +6618,7 @@ Any match of REMOVE-RE will be removed from TXT." (setq duration (- (org-duration-to-minutes s2) (org-duration-to-minutes s1))))) - (when (string-match "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$" txt) + (when (string-match org-tag-group-re txt) ;; Tags are in the string (if (or (eq org-agenda-remove-tags t) (and org-agenda-remove-tags @@ -6514,7 +6626,7 @@ Any match of REMOVE-RE will be removed from TXT." (setq txt (replace-match "" t t txt)) (setq txt (replace-match (concat (make-string (max (- 50 (length txt)) 1) ?\ ) - (match-string 2 txt)) + (match-string 1 txt)) t t txt)))) (when remove-re @@ -6526,14 +6638,16 @@ Any match of REMOVE-RE will be removed from TXT." (add-text-properties 0 (length txt) '(org-heading t) txt) ;; Prepare the variables needed in the eval of the compiled format - (if org-prefix-has-breadcrumbs - (setq breadcrumbs (org-with-point-at (org-get-at-bol 'org-marker) - (let ((s (org-display-outline-path nil nil "->" t))) - (if (eq "" s) "" (concat s "->")))))) + (when org-prefix-has-breadcrumbs + (setq breadcrumbs (org-with-point-at (org-get-at-bol 'org-marker) + (let ((s (org-format-outline-path (org-get-outline-path) + (1- (frame-width)) + nil org-agenda-breadcrumbs-separator))) + (if (eq "" s) "" (concat s org-agenda-breadcrumbs-separator)))))) (setq time (cond (s2 (concat (org-agenda-time-of-day-to-ampm-maybe s1) "-" (org-agenda-time-of-day-to-ampm-maybe s2) - (if org-agenda-timegrid-use-ampm " "))) + (when org-agenda-timegrid-use-ampm " "))) (s1 (concat (org-agenda-time-of-day-to-ampm-maybe s1) (if org-agenda-timegrid-use-ampm @@ -6543,19 +6657,17 @@ Any match of REMOVE-RE will be removed from TXT." extra (or (and (not habitp) extra) "") category (if (symbolp category) (symbol-name category) category) level (or level "")) - (if (string-match org-bracket-link-regexp category) + (if (string-match org-link-bracket-re category) (progn - (setq l (if (match-end 3) - (- (match-end 3) (match-beginning 3)) - (- (match-end 1) (match-beginning 1)))) + (setq l (string-width (or (match-string 2) (match-string 1)))) (when (< l (or org-prefix-category-length 0)) (setq category (copy-sequence category)) (org-add-props category nil 'extra-space (make-string (- org-prefix-category-length l 1) ?\ )))) - (if (and org-prefix-category-max-length - (>= (length category) org-prefix-category-max-length)) - (setq category (substring category 0 (1- org-prefix-category-max-length))))) + (when (and org-prefix-category-max-length + (>= (length category) org-prefix-category-max-length)) + (setq category (substring category 0 (1- org-prefix-category-max-length))))) ;; Evaluate the compiled format (setq rtn (concat (eval formatter) txt)) @@ -6581,8 +6693,8 @@ Any match of REMOVE-RE will be removed from TXT." The modified list may contain inherited tags, and tags matched by `org-agenda-hide-tags-regexp' will be removed." (when (or add-inherited hide-re) - (if (string-match "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$" txt) - (setq txt (substring txt 0 (match-beginning 0)))) + (when (string-match org-tag-group-re txt) + (setq txt (substring txt 0 (match-beginning 0)))) (setq tags (delq nil (mapcar (lambda (tg) @@ -6636,9 +6748,9 @@ TODAYP is t when the current agenda view is on today." (req (car org-agenda-time-grid)) (remove (member 'remove-match req)) new time) - (if (and (member 'require-timed req) (not have)) - ;; don't show empty grid - (throw 'exit list)) + (when (and (member 'require-timed req) (not have)) + ;; don't show empty grid + (throw 'exit list)) (while (setq time (pop gridtimes)) (unless (and remove (member time have)) (setq time (replace-regexp-in-string " " "0" (format "%04s" time))) @@ -6686,10 +6798,11 @@ and stored in the variable `org-prefix-format-compiled'." c (or (match-string 3 s) "") opt (match-beginning 1) start (1+ (match-beginning 0))) - (if (eq var 'time) (setq org-prefix-has-time t)) - (if (eq var 'tag) (setq org-prefix-has-tag t)) - (if (eq var 'effort) (setq org-prefix-has-effort t)) - (if (eq var 'breadcrumbs) (setq org-prefix-has-breadcrumbs t)) + (cl-case var + (time (setq org-prefix-has-time t)) + (tag (setq org-prefix-has-tag t)) + (effort (setq org-prefix-has-effort t)) + (breadcrumbs (setq org-prefix-has-breadcrumbs t))) (setq f (concat "%" (match-string 2 s) "s")) (when (eq var 'category) (setq org-prefix-category-length @@ -6697,8 +6810,8 @@ and stored in the variable `org-prefix-format-compiled'." (setq org-prefix-category-max-length (let ((x (match-string 2 s))) (save-match-data - (if (string-match "\\.[0-9]+" x) - (string-to-number (substring (match-string 0 x) 1))))))) + (and (string-match "\\.[0-9]+" x) + (string-to-number (substring (match-string 0 x) 1))))))) (if (eq var 'eval) (setq varform `(format ,f (org-eval ,(read (match-string 4 s))))) (if opt @@ -6746,7 +6859,7 @@ HH:MM." (not (eq (get-text-property 1 'face s) 'org-link))) (let* ((h (string-to-number (match-string 1 s))) (m (if (match-end 3) (string-to-number (match-string 3 s)) 0)) - (ampm (if (match-end 4) (downcase (match-string 4 s)))) + (ampm (when (match-end 4) (downcase (match-string 4 s)))) (am-p (equal ampm "am")) (h1 (cond ((not ampm) h) ((= h 12) (if am-p 0 12)) @@ -6823,7 +6936,7 @@ The optional argument TYPE tells the agenda type." "Limit the number of agenda entries." (let ((include (and limit (< limit 0)))) (if limit - (let ((fun (or fn (lambda (p) (if p 1)))) + (let ((fun (or fn (lambda (p) (when p 1)))) (lim 0)) (delq nil (mapcar @@ -6831,7 +6944,7 @@ The optional argument TYPE tells the agenda type." (let ((pval (funcall fun (get-text-property (1- (length e)) prop e)))) - (if pval (setq lim (+ lim pval))) + (when pval (setq lim (+ lim pval))) (cond ((and pval (<= lim (abs limit))) e) ((and include (not pval)) e)))) list))) @@ -6969,16 +7082,17 @@ The optional argument TYPE tells the agenda type." (tb (and plb (substring b plb))) (case-fold-search nil)) (when pla - (if (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp a) "") - "\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *") ta) - (setq ta (substring ta (match-end 0)))) + (when (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp a) "") + "\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *") ta) + (setq ta (substring ta (match-end 0)))) (setq ta (downcase ta))) (when plb - (if (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp b) "") - "\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *") tb) - (setq tb (substring tb (match-end 0)))) + (when (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp b) "") + "\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *") tb) + (setq tb (substring tb (match-end 0)))) (setq tb (downcase tb))) - (cond ((not ta) +1) + (cond ((not (or ta tb)) nil) + ((not ta) +1) ((not tb) -1) ((string-lessp ta tb) -1) ((string-lessp tb ta) +1)))) @@ -6987,7 +7101,8 @@ The optional argument TYPE tells the agenda type." "Compare the string values of the first tags of A and B." (let ((ta (car (last (get-text-property 1 'tags a)))) (tb (car (last (get-text-property 1 'tags b))))) - (cond ((not ta) +1) + (cond ((not (or ta tb)) nil) + ((not ta) +1) ((not tb) -1) ((string-lessp ta tb) -1) ((string-lessp tb ta) +1)))) @@ -7074,11 +7189,11 @@ their type." (alpha-down (if alpha-up (- alpha-up) nil)) (need-user-cmp (org-em 'user-defined-up 'user-defined-down ss)) user-defined-up user-defined-down) - (if (and need-user-cmp org-agenda-cmp-user-defined - (functionp org-agenda-cmp-user-defined)) - (setq user-defined-up - (funcall org-agenda-cmp-user-defined a b) - user-defined-down (if user-defined-up (- user-defined-up) nil))) + (when (and need-user-cmp org-agenda-cmp-user-defined + (functionp org-agenda-cmp-user-defined)) + (setq user-defined-up + (funcall org-agenda-cmp-user-defined a b) + user-defined-down (if user-defined-up (- user-defined-up) nil))) (cdr (assoc (eval (cons 'or org-agenda-sorting-strategy-selected)) '((-1 . t) (1 . nil) (nil . nil)))))) @@ -7111,58 +7226,69 @@ Argument ARG is the prefix argument." ;;;###autoload (defun org-agenda-set-restriction-lock (&optional type) - "Set restriction lock for agenda, to current subtree or file. -Restriction will be the file if TYPE is `file', or if type is the -universal prefix \\='(4), or if the cursor is before the first headline -in the file. Otherwise, restriction will be to the current subtree." + "Set restriction lock for agenda to current subtree or file. +When in a restricted subtree, remove it. + +The restriction will span over the entire file if TYPE is `file', +or if type is '(4), or if the cursor is before the first headline +in the file. Otherwise, only apply the restriction to the current +subtree." (interactive "P") - (org-agenda-remove-restriction-lock 'noupdate) - (and (equal type '(4)) (setq type 'file)) - (setq type (cond - (type type) - ((org-at-heading-p) 'subtree) - ((condition-case nil (org-back-to-heading t) (error nil)) - 'subtree) - (t 'file))) - (if (eq type 'subtree) - (progn - (setq org-agenda-restrict (current-buffer)) - (setq org-agenda-overriding-restriction 'subtree) - (put 'org-agenda-files 'org-restrict - (list (buffer-file-name (buffer-base-buffer)))) - (org-back-to-heading t) - (move-overlay org-agenda-restriction-lock-overlay - (point) - (if org-agenda-restriction-lock-highlight-subtree - (save-excursion (org-end-of-subtree t t) (point)) - (point-at-eol))) - (move-marker org-agenda-restrict-begin (point)) - (move-marker org-agenda-restrict-end - (save-excursion (org-end-of-subtree t t))) - (message "Locking agenda restriction to subtree")) - (put 'org-agenda-files 'org-restrict - (list (buffer-file-name (buffer-base-buffer)))) - (setq org-agenda-restrict nil) - (setq org-agenda-overriding-restriction 'file) - (move-marker org-agenda-restrict-begin nil) - (move-marker org-agenda-restrict-end nil) - (message "Locking agenda restriction to file")) - (setq current-prefix-arg nil) + (if (and org-agenda-overriding-restriction + (member org-agenda-restriction-lock-overlay + (overlays-at (point))) + (equal (overlay-start org-agenda-restriction-lock-overlay) + (point))) + (org-agenda-remove-restriction-lock 'noupdate) + (org-agenda-remove-restriction-lock 'noupdate) + (and (equal type '(4)) (setq type 'file)) + (setq type (cond + (type type) + ((org-at-heading-p) 'subtree) + ((condition-case nil (org-back-to-heading t) (error nil)) + 'subtree) + (t 'file))) + (if (eq type 'subtree) + (progn + (setq org-agenda-restrict (current-buffer)) + (setq org-agenda-overriding-restriction 'subtree) + (put 'org-agenda-files 'org-restrict + (list (buffer-file-name (buffer-base-buffer)))) + (org-back-to-heading t) + (move-overlay org-agenda-restriction-lock-overlay + (point) + (if org-agenda-restriction-lock-highlight-subtree + (save-excursion (org-end-of-subtree t t) (point)) + (point-at-eol))) + (move-marker org-agenda-restrict-begin (point)) + (move-marker org-agenda-restrict-end + (save-excursion (org-end-of-subtree t t))) + (message "Locking agenda restriction to subtree")) + (put 'org-agenda-files 'org-restrict + (list (buffer-file-name (buffer-base-buffer)))) + (setq org-agenda-restrict nil) + (setq org-agenda-overriding-restriction 'file) + (move-marker org-agenda-restrict-begin nil) + (move-marker org-agenda-restrict-end nil) + (message "Locking agenda restriction to file")) + (setq current-prefix-arg nil)) (org-agenda-maybe-redo)) (defun org-agenda-remove-restriction-lock (&optional noupdate) - "Remove the agenda restriction lock." + "Remove agenda restriction lock." (interactive "P") - (delete-overlay org-agenda-restriction-lock-overlay) - (delete-overlay org-speedbar-restriction-lock-overlay) - (setq org-agenda-overriding-restriction nil) - (setq org-agenda-restrict nil) - (put 'org-agenda-files 'org-restrict nil) - (move-marker org-agenda-restrict-begin nil) - (move-marker org-agenda-restrict-end nil) - (setq current-prefix-arg nil) - (message "Agenda restriction lock removed") - (or noupdate (org-agenda-maybe-redo))) + (if (not org-agenda-restrict) + (message "No agenda restriction to remove.") + (delete-overlay org-agenda-restriction-lock-overlay) + (delete-overlay org-speedbar-restriction-lock-overlay) + (setq org-agenda-overriding-restriction nil) + (setq org-agenda-restrict nil) + (put 'org-agenda-files 'org-restrict nil) + (move-marker org-agenda-restrict-begin nil) + (move-marker org-agenda-restrict-end nil) + (setq current-prefix-arg nil) + (message "Agenda restriction lock removed") + (or noupdate (org-agenda-maybe-redo)))) (defun org-agenda-maybe-redo () "If there is any window showing the agenda view, update it." @@ -7182,14 +7308,14 @@ in the file. Otherwise, restriction will be to the current subtree." ;;; Agenda commands (defun org-agenda-check-type (error &rest types) - "Check if agenda buffer is of allowed type. + "Check if agenda buffer or component is of allowed type. If ERROR is non-nil, throw an error, otherwise just return nil. Allowed types are `agenda' `todo' `tags' `search'." (cond ((not org-agenda-type) (error "No Org agenda currently displayed")) ((memq org-agenda-type types) t) (error - (error "Not allowed in %s-type agenda buffers" org-agenda-type)) + (error "Not allowed in '%s'-type agenda buffer or component" org-agenda-type)) (t nil))) (defun org-agenda-Quit () @@ -7361,11 +7487,15 @@ With a prefix argument, do so in all agenda buffers." (defvar org-agenda-filter-form nil) (defvar org-agenda-filtered-by-category nil) +(defsubst org-agenda-get-category () + "Return the category of the agenda line." + (org-get-at-bol 'org-category)) + (defun org-agenda-filter-by-category (strip) "Filter lines in the agenda buffer that have a specific category. The category is that of the current line. -Without prefix argument, keep only the lines of that category. -With a prefix argument, exclude the lines of that category." +With a `\\[universal-argument]' prefix argument, exclude the lines of that category. +When there is already a category filter in place, this command removes the filter." (interactive "P") (if (and org-agenda-filtered-by-category org-agenda-category-filter) @@ -7395,7 +7525,8 @@ search from." (defvar org-agenda-filtered-by-top-headline nil) (defun org-agenda-filter-by-top-headline (strip) "Keep only those lines that are descendants from the same top headline. -The top headline is that of the current line." +The top headline is that of the current line. With prefix arg STRIP, hide +all lines of the category at point." (interactive "P") (if org-agenda-filtered-by-top-headline (progn @@ -7407,46 +7538,60 @@ The top headline is that of the current line." (error "No top-level headline at point"))))) (defvar org-agenda-regexp-filter nil) -(defun org-agenda-filter-by-regexp (strip) - "Filter agenda entries by a regular expression. -Regexp filters are cumulative. -With no prefix argument, keep entries matching the regexp. -With one prefix argument, filter out entries matching the regexp. -With two prefix arguments, remove the regexp filters." +(defun org-agenda-filter-by-regexp (strip-or-accumulate) + "Filter agenda entries by a regular expressions. +You will be prompted for the regular expression, and the agenda +view will only show entries that are matched by that expression. + +With one `\\[universal-argument]' prefix argument, hide entries matching the regexp. +When there is already a regexp filter active, this command removed the +filter. However, with two `\\[universal-argument]' prefix arguments, add a new condition to +an already existing regexp filter." (interactive "P") - (if (not (equal strip '(16))) - (let ((flt (concat (if (equal strip '(4)) "-" "+") - (read-from-minibuffer - (if (equal strip '(4)) - "Filter out entries matching regexp: " - "Narrow to entries matching regexp: "))))) - (push flt org-agenda-regexp-filter) - (org-agenda-filter-apply org-agenda-regexp-filter 'regexp)) - (org-agenda-filter-show-all-re) - (message "Regexp filter removed"))) + (let* ((strip (equal strip-or-accumulate '(4))) + (accumulate (equal strip-or-accumulate '(16)))) + (cond + ((and org-agenda-regexp-filter (not accumulate)) + (org-agenda-filter-show-all-re) + (message "Regexp filter removed")) + (t (let ((flt (concat (if strip "-" "+") + (read-from-minibuffer + (if strip + "Hide entries matching regexp: " + "Narrow to entries matching regexp: "))))) + (push flt org-agenda-regexp-filter) + (org-agenda-filter-apply org-agenda-regexp-filter 'regexp)))))) (defvar org-agenda-effort-filter nil) -(defun org-agenda-filter-by-effort (strip) +(defun org-agenda-filter-by-effort (strip-or-accumulate) "Filter agenda entries by effort. -With no prefix argument, keep entries matching the effort condition. -With one prefix argument, filter out entries matching the condition. -With two prefix arguments, remove the effort filters." +With no `\\[universal-argument]' prefix argument, keep entries matching the effort condition. +With one `\\[universal-argument]' prefix argument, filter out entries matching the condition. +With two `\\[universal-argument]' prefix arguments, add a second condition to the existing filter. +This last option is in practice not very useful, but it is available for +consistency with the other filter commands." (interactive "P") - (cond - ((member strip '(nil 4)) - (let* ((efforts (split-string - (or (cdr (assoc (concat org-effort-property "_ALL") - org-global-properties)) - "0 0:10 0:30 1:00 2:00 3:00 4:00 5:00 6:00 7:00"))) - ;; XXX: the following handles only up to 10 different - ;; effort values. - (allowed-keys (if (null efforts) nil - (mapcar (lambda (n) (mod n 10)) ;turn 10 into 0 - (number-sequence 1 (length efforts))))) - (op nil)) - (while (not (memq op '(?< ?> ?=))) - (setq op (read-char-exclusive "Effort operator? (> = or <)"))) - ;; Select appropriate duration. Ignore non-digit characters. + (let* ((efforts (split-string + (or (cdr (assoc (concat org-effort-property "_ALL") + org-global-properties)) + "0 0:10 0:30 1:00 2:00 3:00 4:00 5:00 6:00 7:00"))) + ;; XXX: the following handles only up to 10 different + ;; effort values. + (allowed-keys (if (null efforts) nil + (mapcar (lambda (n) (mod n 10)) ;turn 10 into 0 + (number-sequence 1 (length efforts))))) + (keep (equal strip-or-accumulate '(16))) + (negative (equal strip-or-accumulate '(4))) + (current org-agenda-effort-filter) + (op nil)) + (while (not (memq op '(?< ?> ?= ?_))) + (setq op (read-char-exclusive + "Effort operator? (> = or <) or press `_' again to remove filter"))) + ;; Select appropriate duration. Ignore non-digit characters. + (if (eq op ?_) + (progn + (org-agenda-filter-show-all-effort) + (message "Effort filter removed")) (let ((prompt (apply #'format (concat "Effort %c " @@ -7458,15 +7603,149 @@ With two prefix arguments, remove the effort filters." (while (not (memq eff allowed-keys)) (message prompt) (setq eff (- (read-char-exclusive) 48))) + (org-agenda-filter-show-all-effort) (setq org-agenda-effort-filter - (list (concat (if strip "-" "+") - (char-to-string op) - ;; Numbering is 1 2 3 ... 9 0, but we want - ;; 0 1 2 ... 8 9. - (nth (mod (1- eff) 10) efforts))))) - (org-agenda-filter-apply org-agenda-effort-filter 'effort))) - (t (org-agenda-filter-show-all-effort) - (message "Effort filter removed")))) + (append + (list (concat (if negative "-" "+") + (char-to-string op) + ;; Numbering is 1 2 3 ... 9 0, but we want + ;; 0 1 2 ... 8 9. + (nth (mod (1- eff) 10) efforts))) + (if keep current nil))) + (org-agenda-filter-apply org-agenda-effort-filter 'effort))))) + + +(defun org-agenda-filter (&optional strip-or-accumulate) + "Prompt for a general filter string and apply it to the agenda. + +The string may contain filter elements like + ++category ++tag ++<effort > and = are also allowed as effort operators ++/regexp/ + +Instead of `+', `-' is allowed to strip the agenda of matching entries. +`+' is optional if it is not required to separate two string parts. +Multiple filter elements can be concatenated without spaces, for example + + +work-John<0:10-/plot/ + +selects entries with category `work' and effort estimates below 10 minutes, +and deselects entries with tag `John' or matching the regexp `plot'. + +During entry of the filter, completion for tags, categories and effort +values is offered. Since the syntax for categories and tags is identical +there should be no overlap between categoroes and tags. If there is, tags +get priority. + +A single `\\[universal-argument]' prefix arg STRIP-OR-ACCUMULATE will negate the +entire filter, which can be useful in connection with the prompt history. + +A double `\\[universal-argument] \\[universal-argument]' prefix arg will add the new filter elements to the +existing ones. A shortcut for this is to add an additional `+' at the +beginning of the string, like `+-John'. + +With a triple prefix argument, execute the computed filtering defined in +the variable `org-agenda-auto-exclude-function'." + (interactive "P") + (if (equal strip-or-accumulate '(64)) + ;; Execute the auto-exclude action + (if (not org-agenda-auto-exclude-function) + (user-error "`org-agenda-auto-exclude-function' is undefined") + (org-agenda-filter-show-all-tag) + (setq org-agenda-tag-filter nil) + (dolist (tag (org-agenda-get-represented-tags)) + (let ((modifier (funcall org-agenda-auto-exclude-function tag))) + (when modifier + (push modifier org-agenda-tag-filter)))) + (unless (null org-agenda-tag-filter) + (org-agenda-filter-apply org-agenda-tag-filter 'tag 'expand))) + ;; Prompt for a filter and act + (let* ((tag-list (org-agenda-get-represented-tags)) + (category-list (org-agenda-get-represented-categories)) + (negate (equal strip-or-accumulate '(4))) + (f-string (completing-read + (concat + (if negate "Negative filter" "Filter") + " [+cat-tag<0:10-/regexp/]: ") + 'org-agenda-filter-completion-function)) + (keep (or (if (string-match "^+[-+]" f-string) + (progn (setq f-string (substring f-string 1)) t)) + (equal strip-or-accumulate '(16)))) + (fc (if keep org-agenda-category-filter)) + (ft (if keep org-agenda-tag-filter)) + (fe (if keep org-agenda-effort-filter)) + (fr (if keep org-agenda-regexp-filter)) + pm s) + (while (string-match "^[ \t]*\\([-+]\\)?\\(\\([^-+<>=/ \t]+\\)\\|\\([<>=][0-9:]+\\)\\|\\(/\\([^/]+\\)/?\\)\\)" f-string) + (setq pm (if (match-beginning 1) (match-string 1 f-string) "+")) + (when negate + (setq pm (if (equal pm "+") "-" "+"))) + (cond + ((match-beginning 3) + ;; category or tag + (setq s (match-string 3 f-string)) + (cond + ((member s tag-list) + (add-to-list 'ft (concat pm s) 'append 'equal)) + ((member s category-list) + (add-to-list 'fc (concat pm s) 'append 'equal)) + (t (message + "`%s%s' filter ignored because tag/category is not represented" + pm s)))) + ((match-beginning 4) + ;; effort + (add-to-list 'fe (concat pm (match-string 4 f-string)) t 'equal)) + ((match-beginning 5) + ;; regexp + (add-to-list 'fr (concat pm (match-string 6 f-string)) t 'equal))) + (setq f-string (substring f-string (match-end 0)))) + (org-agenda-filter-remove-all) + (and fc (org-agenda-filter-apply + (setq org-agenda-category-filter fc) 'category)) + (and ft (org-agenda-filter-apply + (setq org-agenda-tag-filter ft) 'tag)) + (and fe (org-agenda-filter-apply + (setq org-agenda-effort-filter fe) 'effort)) + (and fr (org-agenda-filter-apply + (setq org-agenda-regexp-filter fr) 'regexp)) + ))) + +(defun org-agenda-filter-completion-function (string _predicate &optional flag) + "Complete a complex filter string +FLAG specifies the type of completion operation to perform. This +function is passed as a collection function to `completing-read', +which see." + (let ((completion-ignore-case t) ;tags are case-sensitive + (confirm (lambda (x) (stringp x))) + (prefix "") + (operator "") + table) + (when (string-match "^\\(.*\\([-+<>=]\\)\\)\\([^-+<>=]*\\)$" string) + (setq prefix (match-string 1 string) + operator (match-string 2 string) + string (match-string 3 string))) + (cond + ((member operator '("+" "-" "" nil)) + (setq table (append (org-agenda-get-represented-categories) + (org-agenda-get-represented-tags)))) + ((member operator '("<" ">" "=")) + (setq table (split-string + (or (cdr (assoc (concat org-effort-property "_ALL") + org-global-properties)) + "0 0:10 0:30 1:00 2:00 3:00 4:00 5:00 6:00 7:00") + " +"))) + (t (setq table nil))) + (pcase flag + (`t (all-completions string table confirm)) + (`lambda (assoc string table)) ;exact match? + (`nil + (pcase (try-completion string table confirm) + ((and completion (pred stringp)) + (concat prefix completion)) + (completion completion))) + (_ nil)))) (defun org-agenda-filter-remove-all () "Remove all filters from the current agenda buffer." @@ -7483,14 +7762,17 @@ With two prefix arguments, remove the effort filters." (org-agenda-filter-show-all-effort)) (org-agenda-finalize)) -(defun org-agenda-filter-by-tag (arg &optional char exclude) +(defun org-agenda-filter-by-tag (strip-or-accumulate &optional char exclude) "Keep only those lines in the agenda buffer that have a specific tag. The tag is selected with its fast selection letter, as configured. -With a `\\[universal-argument]' prefix, exclude the agenda search. +With a `\\[universal-argument]' prefix, apply the filter negatively, stripping all matches. + +With a `\\[universal-argument] \\[universal-argument]' prefix, add the new tag to the existing filter +instead of replacing it. -With a `\\[universal-argument] \\[universal-argument]' prefix, filter the literal tag, \ +With a `\\[universal-argument] \\[universal-argument] \\[universal-argument]' prefix, filter the literal tag, \ i.e. don't filter on all its group members. @@ -7499,33 +7781,38 @@ should be used to exclude the search - the interactive user can also press `-' or `+' to switch between filtering and excluding." (interactive "P") (let* ((alist org-tag-alist-for-agenda) + (seen-chars nil) (tag-chars (mapconcat (lambda (x) (if (and (not (symbolp (car x))) - (cdr x)) - (char-to-string (cdr x)) + (cdr x) + (not (member (cdr x) seen-chars))) + (progn + (push (cdr x) seen-chars) + (char-to-string (cdr x))) "")) org-tag-alist-for-agenda "")) - (valid-char-list (append '(?\t ?\r ?/ ?. ?\s ?q) + (valid-char-list (append '(?\t ?\r ?\\ ?. ?\s ?q) (string-to-list tag-chars))) - (exclude (or exclude (equal arg '(4)))) - (expand (not (equal arg '(16)))) + (exclude (or exclude (equal strip-or-accumulate '(4)))) + (accumulate (equal strip-or-accumulate '(16))) + (expand (not (equal strip-or-accumulate '(64)))) (inhibit-read-only t) (current org-agenda-tag-filter) a n tag) (unless char (while (not (memq char valid-char-list)) - (message - "%s by tag [%s ]:tag-char, [TAB]:tag, %s[/]:off, [+/-]:filter/exclude%s, [q]:quit" - (if exclude "Exclude" "Filter") + (org-unlogged-message + "%s by tag%s: [%s ]tag-char [TAB]tag %s[\\]off [q]uit" + (if exclude "Exclude[+]" "Filter[-]") + (if expand "" " (no grouptag expand)") tag-chars - (if org-agenda-auto-exclude-function "[RET], " "") - (if expand "" ", no grouptag expand")) + (if org-agenda-auto-exclude-function "[RET] " "")) (setq char (read-char-exclusive)) ;; Excluding or filtering down (cond ((eq char ?-) (setq exclude t)) ((eq char ?+) (setq exclude nil))))) (when (eq char ?\t) - (unless (local-variable-p 'org-global-tags-completion-table (current-buffer)) + (unless (local-variable-p 'org-global-tags-completion-table) (setq-local org-global-tags-completion-table (org-global-tags-completion-table))) (let ((completion-ignore-case t)) @@ -7538,11 +7825,11 @@ also press `-' or `+' to switch between filtering and excluding." (setq org-agenda-tag-filter nil) (dolist (tag (org-agenda-get-represented-tags)) (let ((modifier (funcall org-agenda-auto-exclude-function tag))) - (if modifier - (push modifier org-agenda-tag-filter)))) - (if (not (null org-agenda-tag-filter)) - (org-agenda-filter-apply org-agenda-tag-filter 'tag expand)))) - ((eq char ?/) + (when modifier + (push modifier org-agenda-tag-filter)))) + (unless (null org-agenda-tag-filter) + (org-agenda-filter-apply org-agenda-tag-filter 'tag expand)))) + ((eq char ?\\) (org-agenda-filter-show-all-tag) (when (get 'org-agenda-tag-filter :preset-filter) (org-agenda-filter-apply org-agenda-tag-filter 'tag expand))) @@ -7559,21 +7846,36 @@ also press `-' or `+' to switch between filtering and excluding." (setq tag (car a)) (setq org-agenda-tag-filter (cons (concat (if exclude "-" "+") tag) - current)) + (if accumulate current nil))) (org-agenda-filter-apply org-agenda-tag-filter 'tag expand)) (t (error "Invalid tag selection character %c" char))))) -(defun org-agenda-get-represented-tags () - "Get a list of all tags currently represented in the agenda." - (let (p tags) - (save-excursion - (goto-char (point-min)) - (while (setq p (next-single-property-change (point) 'tags)) - (goto-char p) - (mapc (lambda (x) (add-to-list 'tags x)) - (get-text-property (point) 'tags)))) - tags)) +(defun org-agenda-get-represented-categories () + "Return a list of all categories used in this agenda buffer." + (or org-agenda-represented-categories + (when (derived-mode-p 'org-agenda-mode) + (let ((pos (point-min)) categories) + (while (and (< pos (point-max)) + (setq pos (next-single-property-change + pos 'org-category nil (point-max)))) + (push (get-text-property pos 'org-category) categories)) + (setq org-agenda-represented-categories + (nreverse (org-uniquify (delq nil categories)))))))) +(defun org-agenda-get-represented-tags () + "Return a list of all tags used in this agenda buffer. +These will be lower-case, for filtering." + (or org-agenda-represented-tags + (when (derived-mode-p 'org-agenda-mode) + (let ((pos (point-min)) tags-lists tt) + (while (and (< pos (point-max)) + (setq pos (next-single-property-change + pos 'tags nil (point-max)))) + (setq tt (get-text-property pos 'tags)) + (if tt (push tt tags-lists))) + (setq org-agenda-represented-tags + (nreverse (org-uniquify + (delq nil (apply 'append tags-lists))))))))) (defun org-agenda-filter-make-matcher (filter type &optional expand) "Create the form that tests a line for agenda filter. Optional @@ -7636,7 +7938,7 @@ function to set the right switches in the returned form." (dolist (x tags (cons (if (eq op ?-) 'and 'or) form)) (let* ((tag (substring x 1)) (f (cond - ((string= "" tag) '(not tags)) + ((string= "" tag) 'tags) ((and (string-match-p "\\`{" tag) (string-match-p "}\\'" tag)) ;; TAG is a regexp. (list 'org-match-any-p (substring tag 1 -1) 'tags)) @@ -7689,9 +7991,10 @@ When NO-OPERATOR is non-nil, do not add the + operator to returned tags." argument EXPAND can be used for the TYPE tag and will expand the tags in the FILTER if any of the tags in FILTER are grouptags." ;; Deactivate `org-agenda-entry-text-mode' when filtering - (if org-agenda-entry-text-mode (org-agenda-entry-text-mode)) + (when org-agenda-entry-text-mode (org-agenda-entry-text-mode)) (let (tags cat txt) - (setq org-agenda-filter-form (org-agenda-filter-make-matcher filter type expand)) + (setq org-agenda-filter-form (org-agenda-filter-make-matcher + filter type expand)) ;; Only set `org-agenda-filtered-by-category' to t when a unique ;; category is used as the filter: (setq org-agenda-filtered-by-category @@ -7701,17 +8004,17 @@ tags in the FILTER if any of the tags in FILTER are grouptags." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (if (org-get-at-bol 'org-marker) + (if (org-get-at-bol 'org-hd-marker) (progn (setq tags (org-get-at-bol 'tags) - cat (org-get-at-eol 'org-category 1) + cat (org-agenda-get-category) txt (org-get-at-bol 'txt)) - (if (not (eval org-agenda-filter-form)) - (org-agenda-filter-hide-line type)) + (unless (eval org-agenda-filter-form) + (org-agenda-filter-hide-line type)) (beginning-of-line 2)) (beginning-of-line 2)))) - (if (get-char-property (point) 'invisible) - (ignore-errors (org-agenda-previous-line))))) + (when (get-char-property (point) 'invisible) + (ignore-errors (org-agenda-previous-line))))) (defun org-agenda-filter-top-headline-apply (hl &optional negative) "Filter by top headline HL." @@ -7721,12 +8024,12 @@ tags in the FILTER if any of the tags in FILTER are grouptags." (while (not (eobp)) (let* ((pos (org-get-at-bol 'org-hd-marker)) (tophl (and pos (org-find-top-headline pos)))) - (if (and tophl (funcall (if negative 'identity 'not) - (string= hl tophl))) - (org-agenda-filter-hide-line 'top-headline))) + (when (and tophl (funcall (if negative 'identity 'not) + (string= hl tophl))) + (org-agenda-filter-hide-line 'top-headline))) (beginning-of-line 2))) - (if (get-char-property (point) 'invisible) - (org-agenda-previous-line)) + (when (get-char-property (point) 'invisible) + (org-agenda-previous-line)) (setq org-agenda-top-headline-filter hl org-agenda-filtered-by-top-headline t)) @@ -7744,7 +8047,8 @@ tags in the FILTER if any of the tags in FILTER are grouptags." (save-excursion (goto-char (point-min)) (let ((inhibit-read-only t) pos) - (while (setq pos (text-property-any (point) (point-max) 'org-filter-type type)) + (while (setq pos (text-property-any (point) (point-max) + 'org-filter-type type)) (goto-char pos) (remove-text-properties (point) (next-single-property-change (point) 'org-filter-type) @@ -7955,9 +8259,10 @@ With prefix ARG, go backward that many times the current span." (defun org-agenda-view-mode-dispatch () "Call one of the view mode commands." (interactive) - (message "View: [d]ay [w]eek for[t]night [m]onth [y]ear [SPC]reset [q]uit/abort - time[G]rid [[]inactive [f]ollow [l]og [L]og-all [c]lockcheck - [a]rch-trees [A]rch-files clock[R]eport include[D]iary [E]ntryText") + (org-unlogged-message + "View: [d]ay [w]eek for[t]night [m]onth [y]ear [SPC]reset [q]uit/abort + time[G]rid [[]inactive [f]ollow [l]og [L]og-all [c]lockcheck + [a]rch-trees [A]rch-files clock[R]eport include[D]iary [E]ntryText") (pcase (read-char-exclusive) (?\ (call-interactively 'org-agenda-reset-view)) (?d (call-interactively 'org-agenda-day-view)) @@ -8042,8 +8347,8 @@ SPAN may be `day', `week', `fortnight', `month', `year'." (org-agenda-check-type t 'agenda) (let* ((args (get-text-property (min (1- (point-max)) (point)) 'org-last-args)) (curspan (nth 2 args))) - (if (and (not n) (equal curspan span)) - (error "Viewing span is already \"%s\"" span)) + (when (and (not n) (equal curspan span)) + (error "Viewing span is already \"%s\"" span)) (let* ((sd (or (org-get-at-bol 'day) (nth 1 args) org-starting-day)) @@ -8107,11 +8412,10 @@ so that the date SD will be in that range." (org-agenda-check-type t 'agenda) (beginning-of-line 1) ;; This does not work if user makes date format that starts with a blank - (if (looking-at "^\\S-") (forward-char 1)) - (if (not (re-search-forward "^\\S-" nil t arg)) - (progn - (backward-char 1) - (error "No next date after this line in this buffer"))) + (when (looking-at-p "^\\S-") (forward-char 1)) + (unless (re-search-forward "^\\S-" nil t arg) + (backward-char 1) + (error "No next date after this line in this buffer")) (goto-char (match-beginning 0))) (defun org-agenda-previous-date-line (&optional arg) @@ -8119,8 +8423,8 @@ so that the date SD will be in that range." (interactive "p") (org-agenda-check-type t 'agenda) (beginning-of-line 1) - (if (not (re-search-backward "^\\S-" nil t arg)) - (error "No previous date before this line in this buffer"))) + (unless (re-search-backward "^\\S-" nil t arg) + (error "No previous date before this line in this buffer"))) ;; Initialize the highlight (defvar org-hl (make-overlay 1 1)) @@ -8276,56 +8580,51 @@ When called with a prefix argument, include all archive files as well." ((eq org-agenda-show-log 'clockcheck) " ClkCk") (org-agenda-show-log " Log") (t "")) + (if (org-agenda-filter-any) " " "") (if (or org-agenda-category-filter (get 'org-agenda-category-filter :preset-filter)) '(:eval (propertize - (concat " <" + (concat "[" (mapconcat 'identity (append (get 'org-agenda-category-filter :preset-filter) org-agenda-category-filter) "") - ">") + "]") 'face 'org-agenda-filter-category 'help-echo "Category used in filtering")) "") (if (or org-agenda-tag-filter (get 'org-agenda-tag-filter :preset-filter)) '(:eval (propertize - (concat " {" - (mapconcat + (concat (mapconcat 'identity (append (get 'org-agenda-tag-filter :preset-filter) org-agenda-tag-filter) - "") - "}") + "")) 'face 'org-agenda-filter-tags 'help-echo "Tags used in filtering")) "") (if (or org-agenda-effort-filter (get 'org-agenda-effort-filter :preset-filter)) '(:eval (propertize - (concat " {" - (mapconcat + (concat (mapconcat 'identity (append (get 'org-agenda-effort-filter :preset-filter) org-agenda-effort-filter) - "") - "}") + "")) 'face 'org-agenda-filter-effort 'help-echo "Effort conditions used in filtering")) "") (if (or org-agenda-regexp-filter (get 'org-agenda-regexp-filter :preset-filter)) '(:eval (propertize - (concat " [" - (mapconcat - 'identity + (concat (mapconcat + (lambda (x) (concat (substring x 0 1) "/" (substring x 1) "/")) (append (get 'org-agenda-regexp-filter :preset-filter) org-agenda-regexp-filter) - "") - "]") + "")) 'face 'org-agenda-filter-regexp 'help-echo "Regexp used in filtering")) "") (if org-agenda-archives-mode @@ -8373,7 +8672,7 @@ When called with a prefix argument, include all archive files as well." (goto (save-excursion (move-end-of-line 0) (previous-single-property-change (point) 'org-marker)))) - (if goto (goto-char goto)) + (when goto (goto-char goto)) (org-move-to-column col))) (org-agenda-do-context-action)) @@ -8432,7 +8731,7 @@ Point is in the buffer where the item originated.") (buffer (marker-buffer marker)) (pos (marker-position marker)) (type (org-get-at-bol 'type)) - dbeg dend (n 0) conf) + dbeg dend (n 0)) (org-with-remote-undo buffer (with-current-buffer buffer (save-excursion @@ -8444,14 +8743,20 @@ Point is in the buffer where the item originated.") dend (min (point-max) (1+ (point-at-eol))))) (goto-char dbeg) (while (re-search-forward "^[ \t]*\\S-" dend t) (setq n (1+ n))))) - (setq conf (or (eq t org-agenda-confirm-kill) - (and (numberp org-agenda-confirm-kill) - (> n org-agenda-confirm-kill)))) - (and conf - (not (y-or-n-p - (format "Delete entry with %d lines in buffer \"%s\"? " - n (buffer-name buffer)))) - (error "Abort")) + (when (or (eq t org-agenda-confirm-kill) + (and (numberp org-agenda-confirm-kill) + (> n org-agenda-confirm-kill))) + (let ((win-conf (current-window-configuration))) + (unwind-protect + (and + (prog2 + (org-agenda-tree-to-indirect-buffer nil) + (not (y-or-n-p + (format "Delete entry with %d lines in buffer \"%s\"? " + n (buffer-name buffer)))) + (kill-buffer org-last-indirect-buffer)) + (error "Abort")) + (set-window-configuration win-conf)))) (let ((org-agenda-buffer-name bufname-orig)) (org-remove-subtree-entries-from-agenda buffer dbeg dend)) (with-current-buffer buffer (delete-region dbeg dend)) @@ -8585,9 +8890,9 @@ It also looks at the text of the entry itself." ((and buffer lk) (mapcar (lambda(l) (with-current-buffer buffer - (setq trg (and (string-match org-bracket-link-regexp l) + (setq trg (and (string-match org-link-bracket-re l) (match-string 1 l))) - (if (or (not trg) (string-match org-any-link-re trg)) + (if (or (not trg) (string-match org-link-any-re trg)) (org-with-wide-buffer (goto-char marker) (when (search-forward l nil lkend) @@ -8601,11 +8906,11 @@ It also looks at the text of the entry itself." (goto-char (match-beginning 0)) (org-open-at-point))))) lk)) - ((or (org-in-regexp (concat "\\(" org-bracket-link-regexp "\\)")) + ((or (org-in-regexp (concat "\\(" org-link-bracket-re "\\)")) (save-excursion (beginning-of-line 1) - (looking-at (concat ".*?\\(" org-bracket-link-regexp "\\)")))) - (org-open-link-from-string (match-string 1))) + (looking-at (concat ".*?\\(" org-link-bracket-re "\\)")))) + (org-link-open-from-string (match-string 1))) (t (message "No link to open here"))))) (defun org-agenda-copy-local-variable (var) @@ -8623,8 +8928,8 @@ displayed Org file fills the frame." (interactive) (if (and org-return-follows-link (not (org-get-at-bol 'org-marker)) - (org-in-regexp org-bracket-link-regexp)) - (org-open-link-from-string (match-string 0)) + (org-in-regexp org-link-bracket-re)) + (org-link-open-from-string (match-string 0)) (let* ((marker (or (org-get-at-bol 'org-marker) (org-agenda-error))) (buffer (marker-buffer marker)) @@ -8660,9 +8965,8 @@ if it was hidden in the outline." When called repeatedly, scroll the window that is displaying the buffer. -With a `\\[universal-argument]' prefix, use `org-show-entry' instead of \ -`outline-show-subtree' -to display the item, so that drawers and logbooks stay folded." +With a `\\[universal-argument]' prefix argument, display the item, but \ +fold drawers." (interactive "P") (let ((win (selected-window))) (if (and (window-live-p org-agenda-show-window) @@ -8671,7 +8975,13 @@ to display the item, so that drawers and logbooks stay folded." (select-window org-agenda-show-window) (ignore-errors (scroll-up))) (org-agenda-goto t) - (if arg (org-show-entry) (outline-show-subtree)) + (org-show-entry) + (if arg (org-cycle-hide-drawers 'children) + (org-with-wide-buffer + (narrow-to-region (org-entry-beginning-position) + (org-entry-end-position)) + (org-show-all '(drawers)))) + (when arg ) (setq org-agenda-show-window (selected-window))) (select-window win))) @@ -8703,7 +9013,7 @@ if it was hidden in the outline." (set-window-start (selected-window) (point-at-bol)) (cond ((= more 0) - (outline-hide-subtree) + (org-flag-subtree t) (save-excursion (org-back-to-heading) (run-hook-with-args 'org-cycle-hook 'folded)) @@ -8755,8 +9065,8 @@ docstring of `org-agenda-show-1'." (if (equal org-agenda-cycle-counter 0) (setq org-agenda-cycle-counter 2) (setq org-agenda-cycle-counter (1+ org-agenda-cycle-counter)) - (if (> org-agenda-cycle-counter 3) - (setq org-agenda-cycle-counter 0))))) + (when (> org-agenda-cycle-counter 3) + (setq org-agenda-cycle-counter 0))))) (org-agenda-show-1 org-agenda-cycle-counter)) (defun org-agenda-recenter (arg) @@ -8775,8 +9085,8 @@ docstring of `org-agenda-show-1'." (defun org-agenda-check-no-diary () "Check if the entry is a diary link and abort if yes." - (if (org-get-at-bol 'org-agenda-diary-link) - (org-agenda-error))) + (when (org-get-at-bol 'org-agenda-diary-link) + (org-agenda-error))) (defun org-agenda-error () "Throw an error when a command is not allowed in the agenda." @@ -8822,7 +9132,7 @@ the dedicated frame." (with-current-buffer buffer (save-excursion (goto-char pos) - (funcall 'org-tree-to-indirect-buffer arg))))) + (org-tree-to-indirect-buffer arg))))) (defvar org-last-heading-marker (make-marker) "Marker pointing to the headline that last changed its TODO state @@ -8852,6 +9162,7 @@ the same tree node, and the headline of the tree node in the Org file." (hdmarker (org-get-at-bol 'org-hd-marker)) (todayp (org-agenda-today-p (org-get-at-bol 'day))) (inhibit-read-only t) + org-loop-over-headlines-in-active-region org-agenda-headline-snapshot-before-repeat newhead just-one) (org-with-remote-undo buffer (with-current-buffer buffer @@ -8912,9 +9223,7 @@ If FORCE-TAGS is non-nil, the car of it returns the new tags." (line (org-current-line)) (org-agenda-buffer (current-buffer)) (thetags (with-current-buffer (marker-buffer hdmarker) - (org-with-wide-buffer - (goto-char hdmarker) - (org-get-tags-at)))) + (org-get-tags hdmarker))) props m pl undone-face done-face finish new dotime level cat tags) (save-excursion (goto-char (point-max)) @@ -8926,7 +9235,7 @@ If FORCE-TAGS is non-nil, the car of it returns the new tags." (equal m hdmarker)) (setq props (text-properties-at (point)) dotime (org-get-at-bol 'dotime) - cat (org-get-at-eol 'org-category 1) + cat (org-agenda-get-category) level (org-get-at-bol 'level) tags thetags new @@ -8970,32 +9279,35 @@ If FORCE-TAGS is non-nil, the car of it returns the new tags." (beginning-of-line 0))))) (defun org-agenda-align-tags (&optional line) - "Align all tags in agenda items to `org-agenda-tags-column'." + "Align all tags in agenda items to `org-agenda-tags-column'. +When optional argument LINE is non-nil, align tags only on the +current line." (let ((inhibit-read-only t) (org-agenda-tags-column (if (eq 'auto org-agenda-tags-column) (- (window-text-width)) org-agenda-tags-column)) + (end (and line (line-end-position))) l c) (save-excursion - (goto-char (if line (point-at-bol) (point-min))) - (while (re-search-forward "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$" - (if line (point-at-eol) nil) t) + (goto-char (if line (line-beginning-position) (point-min))) + (while (re-search-forward org-tag-group-re end t) (add-text-properties - (match-beginning 2) (match-end 2) + (match-beginning 1) (match-end 1) (list 'face (delq nil (let ((prop (get-text-property - (match-beginning 2) 'face))) + (match-beginning 1) 'face))) (or (listp prop) (setq prop (list prop))) (if (memq 'org-tag prop) prop (cons 'org-tag prop)))))) - (setq l (- (match-end 2) (match-beginning 2)) + (setq l (string-width (match-string 1)) c (if (< org-agenda-tags-column 0) (- (abs org-agenda-tags-column) l) org-agenda-tags-column)) - (delete-region (match-beginning 1) (match-end 1)) (goto-char (match-beginning 1)) + (delete-region (save-excursion (skip-chars-backward " \t") (point)) + (point)) (insert (org-add-props - (make-string (max 1 (- c (current-column))) ?\ ) + (make-string (max 1 (- c (current-column))) ?\s) (plist-put (copy-sequence (text-properties-at (point))) 'face nil)))) (goto-char (point-min)) @@ -9035,7 +9347,7 @@ Called with a universal prefix arg, show the priority instead of setting it." (widen) (goto-char pos) (org-show-context 'agenda) - (funcall 'org-priority force-direction) + (org-priority force-direction) (end-of-line 1) (setq newhead (org-get-heading))) (org-agenda-change-all-lines newhead hdmarker) @@ -9061,7 +9373,7 @@ Called with a universal prefix arg, show the priority instead of setting it." (org-show-context 'agenda) (if tag (org-toggle-tag tag onoff) - (call-interactively 'org-set-tags)) + (call-interactively #'org-set-tags-command)) (end-of-line 1) (setq newhead (org-get-heading))) (org-agenda-change-all-lines newhead hdmarker) @@ -9180,9 +9492,9 @@ Called with a universal prefix arg, show the priority instead of setting it." cdate (calendar-absolute-from-gregorian (list (nth 4 cdate) (nth 3 cdate) (nth 5 cdate))) today (org-today)) - (if (> today cdate) - ;; immediately shift to today - (setq arg (- today cdate)))) + (when (> today cdate) + ;; immediately shift to today + (setq arg (- today cdate)))) (org-timestamp-change arg (or what 'day)) (when (and (org-at-date-range-p) (re-search-backward org-tr-regexp-both (point-at-bol))) @@ -9315,7 +9627,6 @@ ARG is passed through to `org-deadline'." (widen) (goto-char pos) (org-show-context 'agenda) - (org-cycle-hide-drawers 'children) (org-clock-in arg) (setq newhead (org-get-heading))) (org-agenda-change-all-lines newhead hdmarker)) @@ -9355,8 +9666,8 @@ buffer, display it in another window." (interactive) (let (pos) (mapc (lambda (o) - (if (eq (overlay-get o 'type) 'org-agenda-clocking) - (setq pos (overlay-start o)))) + (when (eq (overlay-get o 'type) 'org-agenda-clocking) + (setq pos (overlay-start o)))) (overlays-in (point-min) (point-max))) (cond (pos (goto-char pos)) ;; If the currently clocked entry is not in the agenda @@ -9442,62 +9753,64 @@ the resulting entry will not be shown. When TEXT is empty, switch to (find-file-noselect org-agenda-diary-file)) (widen) (goto-char (point-min)) - (cond - ((eq type 'anniversary) - (or (re-search-forward "^\\*[ \t]+Anniversaries" nil t) - (progn - (or (org-at-heading-p t) - (progn - (outline-next-heading) - (insert "* Anniversaries\n\n") - (beginning-of-line -1))))) - (outline-next-heading) - (org-back-over-empty-lines) - (backward-char 1) - (insert "\n") - (insert (format "%%%%(org-anniversary %d %2d %2d) %s" - (nth 2 d1) (car d1) (nth 1 d1) text))) - ((eq type 'day) - (let ((org-prefix-has-time t) - (org-agenda-time-leading-zero t) - fmt time time2) - (if org-agenda-insert-diary-extract-time - ;; Use org-agenda-format-item to parse text for a time-range and - ;; remove it. FIXME: This is a hack, we should refactor - ;; that function to make time extraction available separately - (setq fmt (org-agenda-format-item nil text nil nil nil t) - time (get-text-property 0 'time fmt) - time2 (if (> (length time) 0) - ;; split-string removes trailing ...... if - ;; no end time given. First space - ;; separates time from date. - (concat " " (car (split-string time "\\."))) - nil) - text (get-text-property 0 'txt fmt))) - (if (eq org-agenda-insert-diary-strategy 'top-level) - (org-agenda-insert-diary-as-top-level text) - (require 'org-datetree) - (org-datetree-find-date-create d1) - (org-agenda-insert-diary-make-new-entry text)) - (org-insert-time-stamp (org-time-from-absolute - (calendar-absolute-from-gregorian d1)) - nil nil nil nil time2)) - (end-of-line 0)) - ((eq type 'block) - (if (> (calendar-absolute-from-gregorian d1) - (calendar-absolute-from-gregorian d2)) - (setq d1 (prog1 d2 (setq d2 d1)))) - (if (eq org-agenda-insert-diary-strategy 'top-level) - (org-agenda-insert-diary-as-top-level text) - (require 'org-datetree) - (org-datetree-find-date-create d1) - (org-agenda-insert-diary-make-new-entry text)) - (org-insert-time-stamp (org-time-from-absolute - (calendar-absolute-from-gregorian d1))) - (insert "--") - (org-insert-time-stamp (org-time-from-absolute - (calendar-absolute-from-gregorian d2))) - (end-of-line 0))) + (cl-case type + (anniversary + (or (re-search-forward "^\\*[ \t]+Anniversaries" nil t) + (progn + (or (org-at-heading-p t) + (progn + (outline-next-heading) + (insert "* Anniversaries\n\n") + (beginning-of-line -1))))) + (outline-next-heading) + (org-back-over-empty-lines) + (backward-char 1) + (insert "\n") + (insert (format "%%%%(org-anniversary %d %2d %2d) %s" + (nth 2 d1) (car d1) (nth 1 d1) text))) + (day + (let ((org-prefix-has-time t) + (org-agenda-time-leading-zero t) + fmt time time2) + (when org-agenda-insert-diary-extract-time + ;; Use org-agenda-format-item to parse text for a time-range and + ;; remove it. FIXME: This is a hack, we should refactor + ;; that function to make time extraction available separately + (setq fmt (org-agenda-format-item nil text nil nil nil t) + time (get-text-property 0 'time fmt) + time2 (if (> (length time) 0) + ;; split-string removes trailing ...... if + ;; no end time given. First space + ;; separates time from date. + (concat " " (car (split-string time "\\."))) + nil) + text (get-text-property 0 'txt fmt))) + (if (eq org-agenda-insert-diary-strategy 'top-level) + (org-agenda-insert-diary-as-top-level text) + (require 'org-datetree) + (org-datetree-find-date-create d1) + (org-agenda-insert-diary-make-new-entry text)) + (org-insert-time-stamp (org-time-from-absolute + (calendar-absolute-from-gregorian d1)) + nil nil nil nil time2)) + (end-of-line 0)) + ((block) ;; Wrap this in (strictly unnecessary) parens because + ;; otherwise the indentation gets confused by the + ;; special meaning of 'block + (when (> (calendar-absolute-from-gregorian d1) + (calendar-absolute-from-gregorian d2)) + (setq d1 (prog1 d2 (setq d2 d1)))) + (if (eq org-agenda-insert-diary-strategy 'top-level) + (org-agenda-insert-diary-as-top-level text) + (require 'org-datetree) + (org-datetree-find-date-create d1) + (org-agenda-insert-diary-make-new-entry text)) + (org-insert-time-stamp (org-time-from-absolute + (calendar-absolute-from-gregorian d1))) + (insert "--") + (org-insert-time-stamp (org-time-from-absolute + (calendar-absolute-from-gregorian d2))) + (end-of-line 0))) (if (string-match "\\S-" text) (progn (set-window-configuration cw) @@ -9554,9 +9867,9 @@ entries in that Org file." (if (not (eq org-agenda-diary-file 'diary-file)) (org-agenda-diary-entry-in-org-file) (require 'diary-lib) - (let* ((char (progn - (message "Diary entry: [d]ay [w]eekly [m]onthly [y]early [a]nniversary [b]lock [c]yclic") - (read-char-exclusive))) + (let* ((char (read-char-exclusive + "Diary entry: [d]ay [w]eekly [m]onthly [y]early\ + [a]nniversary [b]lock [c]yclic")) (cmd (cdr (assoc char '((?d . diary-insert-entry) (?w . diary-insert-weekly-entry) @@ -9701,8 +10014,20 @@ This is a command that has to be installed in `calendar-mode-map'." 'org-marked-entry-overlay)) (defun org-agenda-bulk-mark (&optional arg) - "Mark the entry at point for future bulk action." + "Mark entries for future bulk action. + +When ARG is nil or one and region is not active then mark the +entry at point. + +When ARG is nil or one and region is active then mark the entries +in the region. + +When ARG is greater than one mark ARG lines." (interactive "p") + (when (and (or (not arg) (= arg 1)) (use-region-p)) + (setq arg (count-lines (region-beginning) (region-end))) + (goto-char (region-beginning)) + (deactivate-mark)) (dotimes (i (or arg 1)) (unless (org-get-at-bol 'org-agenda-diary-link) (let* ((m (org-get-at-bol 'org-hd-marker)) @@ -9720,9 +10045,9 @@ This is a command that has to be installed in `calendar-mode-map'." (goto-char (next-single-property-change (point) 'org-hd-marker))) (beginning-of-line 2)) (while (and (get-char-property (point) 'invisible) (not (eobp))) - (beginning-of-line 2)) - (message "%d entries marked for bulk action" - (length org-agenda-bulk-marked-entries)))))) + (beginning-of-line 2))))) + (message "%d entries marked for bulk action" + (length org-agenda-bulk-marked-entries))) (defun org-agenda-bulk-mark-all () "Mark all entries for future agenda bulk action." @@ -9744,8 +10069,8 @@ This is a command that has to be installed in `calendar-mode-map'." (setq entries-marked (1+ entries-marked)) (call-interactively 'org-agenda-bulk-mark))))) - (if (not entries-marked) - (message "No entry matching this regexp.")))) + (unless entries-marked + (message "No entry matching this regexp.")))) (defun org-agenda-bulk-unmark (&optional arg) "Unmark the entry at point for future bulk action." @@ -9817,8 +10142,9 @@ bulk action." "Execute an remote-editing action on all marked entries. The prefix arg is passed through to the command if possible." (interactive "P") - ;; Make sure we have markers, and only valid ones. - (unless org-agenda-bulk-marked-entries (user-error "No entries are marked")) + ;; When there is no mark, act on the agenda entry at point. + (if (not org-agenda-bulk-marked-entries) + (save-excursion (org-agenda-bulk-mark))) (dolist (m org-agenda-bulk-marked-entries) (unless (and (markerp m) (marker-buffer m) @@ -9827,8 +10153,8 @@ The prefix arg is passed through to the command if possible." (user-error "Marker %s for bulk command is invalid" m))) ;; Prompt for the bulk command. - (message - (concat (if org-agenda-persistent-marks "Bulk (persistent): " "Bulk: ") + (org-unlogged-message + (concat "Bulk (" (if org-agenda-persistent-marks "" "don't ") "[p]ersist marks): " "[$]arch [A]rch->sib [t]odo [+/-]tag [s]chd [d]eadline [r]efile " "[S]catter [f]unction " (and org-agenda-bulk-custom-functions @@ -10145,9 +10471,9 @@ details and examples. If an entry has a APPT_WARNTIME property, its value will be used to override `appt-message-warning-time'." (interactive "P") - (if refresh (setq appt-time-msg-list nil)) - (if (eq filter t) - (setq filter (read-from-minibuffer "Regexp filter: "))) + (when refresh (setq appt-time-msg-list nil)) + (when (eq filter t) + (setq filter (read-from-minibuffer "Regexp filter: "))) (let* ((cnt 0) ; count added events (scope (or args '(:deadline* :scheduled* :timestamp))) (org-agenda-new-buffers nil) @@ -10155,7 +10481,8 @@ to override `appt-message-warning-time'." ;; Do not use `org-today' here because appt only takes ;; time and without date as argument, so it may pass wrong ;; information otherwise - (today (org-date-to-gregorian (time-to-days nil))) + (today (org-date-to-gregorian + (time-to-days nil))) (org-agenda-restrict nil) (files (org-agenda-files 'unrestricted)) entries file (org-agenda-buffer nil)) @@ -10167,12 +10494,12 @@ to override `appt-message-warning-time'." (append entries (apply 'org-agenda-get-day-entries file today scope))))) - ;; Map thru entries and find if we should filter them out + ;; Map through entries and find if we should filter them out (mapc (lambda (x) (let* ((evt (org-trim (replace-regexp-in-string - org-bracket-link-regexp "\\3" + org-link-bracket-re "\\2" (or (get-text-property 1 'txt x) "")))) (cat (get-text-property (1- (length x)) 'org-category x)) (tod (get-text-property 1 'time-of-day x)) diff --git a/lisp/org/org-archive.el b/lisp/org/org-archive.el index dc0dfa4b20b..4721ef79755 100644 --- a/lisp/org/org-archive.el +++ b/lisp/org/org-archive.el @@ -29,6 +29,7 @@ ;;; Code: (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)) @@ -126,22 +127,6 @@ Hook functions are called with point on the subtree in the original file. At this stage, the subtree has been added to the archive location, but not yet deleted from the original file.") -(defun org-get-local-archive-location () - "Get the archive location applicable at point." - (let ((re "^[ \t]*#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") - prop) - (save-excursion - (save-restriction - (widen) - (setq prop (org-entry-get nil "ARCHIVE" 'inherit)) - (cond - ((and prop (string-match "\\S-" prop)) - prop) - ((or (re-search-backward re nil t) - (re-search-forward re nil t)) - (match-string 1)) - (t org-archive-location)))))) - ;;;###autoload (defun org-add-archive-files (files) "Splice the archive files into the list of files. @@ -159,47 +144,36 @@ archive file is." files)))) (defun org-all-archive-files () - "Get a list of all archive files used in the current buffer." - (let ((case-fold-search t) - files) - (org-with-wide-buffer - (goto-char (point-min)) - (while (re-search-forward - "^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)" - nil t) - (when (save-match-data - (if (eq (match-string 1) ":") (org-at-property-p) - (eq (org-element-type (org-element-at-point)) 'keyword))) - (let ((file (org-extract-archive-file - (match-string-no-properties 2)))) - (when (and (org-string-nw-p file) (file-exists-p file)) - (push file files)))))) - (setq files (nreverse files)) - (let ((file (org-extract-archive-file))) - (when (and (org-string-nw-p file) (file-exists-p file)) - (push file files))) - files)) - -(defun org-extract-archive-file (&optional location) - "Extract and expand the file name from archive LOCATION. -if LOCATION is not given, the value of `org-archive-location' is used." - (setq location (or location org-archive-location)) - (if (string-match "\\(.*\\)::\\(.*\\)" location) - (if (= (match-beginning 1) (match-end 1)) - (buffer-file-name (buffer-base-buffer)) - (expand-file-name - (format (match-string 1 location) - (file-name-nondirectory - (buffer-file-name (buffer-base-buffer)))))))) - -(defun org-extract-archive-heading (&optional location) - "Extract the heading from archive LOCATION. -if LOCATION is not given, the value of `org-archive-location' is used." - (setq location (or location org-archive-location)) - (if (string-match "\\(.*\\)::\\(.*\\)" location) - (format (match-string 2 location) - (file-name-nondirectory - (buffer-file-name (buffer-base-buffer)))))) + "List of all archive files used in the current buffer." + (let* ((case-fold-search t) + (files `(,(car (org-archive--compute-location org-archive-location))))) + (org-with-point-at 1 + (while (re-search-forward "^[ \t]*:ARCHIVE:" nil t) + (when (org-at-property-p) + (pcase (org-archive--compute-location (match-string 3)) + (`(,file . ,_) + (when (org-string-nw-p file) + (cl-pushnew file files :test #'file-equal-p)))))) + (cl-remove-if-not #'file-exists-p (nreverse files))))) + +(defun org-archive--compute-location (location) + "Extract and expand the location from archive LOCATION. +Return a pair (FILE . HEADING) where FILE is the file name and +HEADING the heading of the archive location, as strings. Raise +an error if LOCATION is not a valid archive location." + (unless (string-match "::" location) + (error "Invalid archive location: %S" location)) + (let ((current-file (buffer-file-name (buffer-base-buffer))) + (file-fmt (substring location 0 (match-beginning 0))) + (heading-fmt (substring location (match-end 0)))) + (cons + ;; File part. + (if (org-string-nw-p file-fmt) + (expand-file-name + (format file-fmt (file-name-nondirectory current-file))) + current-file) + ;; Heading part. + (format heading-fmt (file-name-nondirectory current-file))))) ;;;###autoload (defun org-archive-subtree (&optional find-done) @@ -231,7 +205,7 @@ direct children of this heading." ((equal find-done '(4)) (org-archive-all-done)) ((equal find-done '(16)) (org-archive-all-old)) (t - ;; Save all relevant TODO keyword-relatex variables + ;; Save all relevant TODO keyword-related variables. (let* ((tr-org-todo-keywords-1 org-todo-keywords-1) (tr-org-todo-kwd-alist org-todo-kwd-alist) (tr-org-done-keywords org-done-keywords) @@ -244,10 +218,11 @@ direct children of this heading." (file (abbreviate-file-name (or (buffer-file-name (buffer-base-buffer)) (error "No file associated to buffer")))) - (location (org-get-local-archive-location)) - (afile (or (org-extract-archive-file location) - (error "Invalid `org-archive-location'"))) - (heading (org-extract-archive-heading location)) + (location (org-archive--compute-location + (or (org-entry-get nil "ARCHIVE" 'inherit) + org-archive-location))) + (afile (car location)) + (heading (cdr location)) (infile-p (equal file (abbreviate-file-name (or afile "")))) (newfile-p (and (org-string-nw-p afile) (not (file-exists-p afile)))) @@ -271,9 +246,15 @@ direct children of this heading." (org-back-to-heading t) ;; Get context information that will be lost by moving the ;; tree. See `org-archive-save-context-info'. - (let* ((all-tags (org-get-tags-at)) - (local-tags (org-get-tags)) - (inherited-tags (org-delete-all local-tags all-tags)) + (let* ((all-tags (org-get-tags)) + (local-tags + (cl-remove-if (lambda (tag) + (get-text-property 0 'inherited tag)) + all-tags)) + (inherited-tags + (cl-remove-if-not (lambda (tag) + (get-text-property 0 'inherited tag)) + all-tags)) (context `((category . ,(org-get-category nil 'force-refresh)) (file . ,file) @@ -315,12 +296,12 @@ direct children of this heading." org-odd-levels-only tr-org-odd-levels-only))) (goto-char (point-min)) - (outline-show-all) + (org-show-all '(headings blocks)) (if (and heading (not (and datetree-date (not datetree-subheading-p)))) (progn (if (re-search-forward (concat "^" (regexp-quote heading) - "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)") + "\\([ \t]+:\\(" org-tag-re ":\\)+\\)?[ \t]*$") nil t) (goto-char (match-end 0)) ;; Heading not found, just insert it at the end @@ -345,8 +326,7 @@ direct children of this heading." (if org-archive-reversed-order (progn (goto-char (point-min)) - (unless (org-at-heading-p) (outline-next-heading)) - (insert "\n") (backward-char 1)) + (unless (org-at-heading-p) (outline-next-heading))) (goto-char (point-max)) ;; Subtree narrowing can let the buffer end on ;; a headline. `org-paste-subtree' then deletes it. @@ -361,7 +341,7 @@ direct children of this heading." (or (and (eq org-archive-subtree-add-inherited-tags 'infile) infile-p) (eq org-archive-subtree-add-inherited-tags t)) - (org-set-tags-to all-tags)) + (org-set-tags all-tags)) ;; Mark the entry as done (when (and org-archive-mark-done (let ((case-fold-search nil)) @@ -390,6 +370,12 @@ direct children of this heading." (when (featurep 'org-inlinetask) (org-inlinetask-remove-END-maybe)) (setq org-markers-to-move nil) + (when org-provide-todo-statistics + (save-excursion + ;; Go to parent, even if no children exist. + (org-up-heading-safe) + ;; Update cookie of parent. + (org-update-statistics-cookies nil))) (message "Subtree archived %s" (if (eq this-buffer buffer) (concat "under heading: " heading) @@ -416,7 +402,7 @@ Archiving time is retained in the ARCHIVE_TIME node property." '(progn (setq org-map-continue-from (progn (org-back-to-heading) (if (looking-at (concat "^.*:" org-archive-tag ":.*$")) - (org-end-of-subtree t) + (org-end-of-subtree t) (point)))) (when (org-at-heading-p) (org-archive-to-archive-sibling))) @@ -464,8 +450,11 @@ Archiving time is retained in the ARCHIVE_TIME node property." (format-time-string (substring (cdr org-time-stamp-formats) 1 -1))) (outline-up-heading 1 t) - (outline-hide-subtree) + (org-flag-subtree t) (org-cycle-show-empty-lines 'folded) + (when org-provide-todo-statistics + ;; Update TODO statistics of parent. + (org-update-parent-todo-statistics)) (goto-char pos))) (org-reveal) (if (looking-at "^[ \t]*$") diff --git a/lisp/org/org-attach-git.el b/lisp/org/org-attach-git.el new file mode 100644 index 00000000000..525495f8c6b --- /dev/null +++ b/lisp/org/org-attach-git.el @@ -0,0 +1,119 @@ +;;; org-attach-git.el --- Automatic git commit extension to org-attach -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Original Author: John Wiegley <johnw@newartisans.com> +;; Restructurer: Gustav Wikström <gustav@whil.se> +;; Keywords: org data git + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; An extension to org-attach. If `org-attach-id-dir' is initialized +;; as a Git repository, then org-attach-git will automatically commit +;; changes when it sees them. Requires git-annex. + +;;; Code: + +(require 'org-attach) +(require 'vc-git) + +(defcustom org-attach-git-annex-cutoff (* 32 1024) + "If non-nil, files larger than this will be annexed instead of stored." + :group 'org-attach + :version "24.4" + :package-version '(Org . "8.0") + :type '(choice + (const :tag "None" nil) + (integer :tag "Bytes"))) + +(defcustom org-attach-git-annex-auto-get 'ask + "Confirmation preference for automatically getting annex files. +If \\='ask, prompt using `y-or-n-p'. If t, always get. If nil, never get." + :group 'org-attach + :package-version '(Org . "9.0") + :version "26.1" + :type '(choice + (const :tag "confirm with `y-or-n-p'" ask) + (const :tag "always get from annex if necessary" t) + (const :tag "never get from annex" nil))) + +(defun org-attach-git-use-annex () + "Return non-nil if git annex can be used." + (let ((git-dir (vc-git-root (expand-file-name org-attach-id-dir)))) + (and org-attach-git-annex-cutoff + (or (file-exists-p (expand-file-name "annex" git-dir)) + (file-exists-p (expand-file-name ".git/annex" git-dir)))))) + +(defun org-attach-git-annex-get-maybe (path) + "Call git annex get PATH (via shell) if using git annex. +Signals an error if the file content is not available and it was not retrieved." + (let* ((default-directory (expand-file-name org-attach-id-dir)) + (path-relative (file-relative-name path))) + (when (and (org-attach-git-use-annex) + (not + (string-equal + "found" + (shell-command-to-string + (format "git annex find --format=found --in=here %s" + (shell-quote-argument path-relative)))))) + (let ((should-get + (if (eq org-attach-git-annex-auto-get 'ask) + (y-or-n-p (format "Run git annex get %s? " path-relative)) + org-attach-git-annex-auto-get))) + (unless should-get + (error "File %s stored in git annex but unavailable" path)) + (message "Running git annex get \"%s\"." path-relative) + (call-process "git" nil nil nil "annex" "get" path-relative))))) + +(defun org-attach-git-commit (&optional _) + "Commit changes to git if `org-attach-id-dir' is properly initialized. +This checks for the existence of a \".git\" directory in that directory. + +Takes an unused optional argument for the sake of being compatible +with hook `org-attach-after-change-hook'." + (let* ((dir (expand-file-name org-attach-id-dir)) + (git-dir (vc-git-root dir)) + (use-annex (org-attach-git-use-annex)) + (changes 0)) + (when (and git-dir (executable-find "git")) + (with-temp-buffer + (cd dir) + (dolist (new-or-modified + (split-string + (shell-command-to-string + "git ls-files -zmo --exclude-standard") "\0" t)) + (if (and use-annex + (>= (file-attribute-size (file-attributes new-or-modified)) + org-attach-git-annex-cutoff)) + (call-process "git" nil nil nil "annex" "add" new-or-modified) + (call-process "git" nil nil nil "add" new-or-modified)) + (cl-incf changes)) + (dolist (deleted + (split-string + (shell-command-to-string "git ls-files -z --deleted") "\0" t)) + (call-process "git" nil nil nil "rm" deleted) + (cl-incf changes)) + (when (> changes 0) + (shell-command "git commit -m 'Synchronized attachments'")))))) + +(add-hook 'org-attach-after-change-hook 'org-attach-git-commit) +(add-hook 'org-attach-open-hook 'org-attach-git-annex-get-maybe) + +(provide 'org-attach-git) + +;;; org-attach-git.el ends here diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el index f430cd5ed3e..bc49be7fe74 100644 --- a/lisp/org/org-attach.el +++ b/lisp/org/org-attach.el @@ -1,9 +1,9 @@ -;;; org-attach.el --- Manage file attachments to Org tasks -*- lexical-binding: t; -*- +;;; org-attach.el --- Manage file attachments to Org outlines -*- lexical-binding: t; -*- ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. ;; Author: John Wiegley <johnw@newartisans.com> -;; Keywords: org data task +;; Keywords: org data attachment ;; This file is part of GNU Emacs. ;; @@ -24,54 +24,44 @@ ;; See the Org manual for information on how to use it. ;; -;; Attachments are managed in a special directory called "data", which -;; lives in the same directory as the org file itself. If this data -;; directory is initialized as a Git repository, then org-attach will -;; automatically commit changes when it sees them. -;; -;; Attachment directories are identified using a UUID generated for the -;; task which has the attachments. These are added as property to the -;; task when necessary, and should not be deleted or changed by the -;; user, ever. UUIDs are generated by a mechanism defined in the variable -;; `org-id-method'. +;; Attachments are managed either by using a custom property DIR or by +;; using property ID from org-id. When DIR is defined, a location in +;; the filesystem is directly attached to the outline node. When +;; org-id is used, attachments are stored in a folder named after the +;; ID, in a location defined by `org-attach-id-dir'. DIR has +;; precedence over ID when both parameters are defined for the current +;; outline node (also when inherited parameters are taken into +;; account). ;;; Code: (require 'cl-lib) (require 'org) +(require 'ol) (require 'org-id) -(require 'vc-git) (declare-function dired-dwim-target-directory "dired-aux") (defgroup org-attach nil - "Options concerning entry attachments in Org mode." + "Options concerning attachments in Org mode." :tag "Org Attach" :group 'org) -(defcustom org-attach-directory "data/" +(defcustom org-attach-id-dir "data/" "The directory where attachments are stored. If this is a relative path, it will be interpreted relative to the directory where the Org file lives." :group 'org-attach - :type 'directory) + :type 'directory + :safe #'stringp) -(defcustom org-attach-commit t - "If non-nil commit attachments with git. -This is only done if the Org file is in a git repository." +(defcustom org-attach-dir-relative nil + "Non-nil means directories in DIR property are added as relative links. +Defaults to absolute location." :group 'org-attach :type 'boolean - :version "26.1" - :package-version '(Org . "9.0")) - -(defcustom org-attach-git-annex-cutoff (* 32 1024) - "If non-nil, files larger than this will be annexed instead of stored." - :group 'org-attach - :version "24.4" - :package-version '(Org . "8.0") - :type '(choice - (const :tag "None" nil) - (integer :tag "Bytes"))) + :package-version '(Org . "9.3") + :safe #'booleanp) (defcustom org-attach-auto-tag "ATTACH" "Tag that will be triggered automatically when an entry has an attachment." @@ -80,15 +70,27 @@ This is only done if the Org file is in a git repository." (const :tag "None" nil) (string :tag "Tag"))) -(defcustom org-attach-file-list-property "Attachments" - "The property used to keep a list of attachment belonging to this entry. -This is not really needed, so you may set this to nil if you don't want it. -Also, for entries where children inherit the directory, the list of -attachments is not kept in this property." +(defcustom org-attach-preferred-new-method 'id + "Preferred way to attach to nodes without existing ID and DIR property. +This choice is used when adding attachments to nodes without ID +and DIR properties. + +Allowed values are: + +id Create and use an ID parameter +dir Create and use a DIR parameter +ask Ask the user for input of which method to choose +nil Prefer to not create a new parameter + + nil means that ID or DIR has to be created explicitly + before attaching files." :group 'org-attach + :package-version '(org . "9.3") :type '(choice - (const :tag "None" nil) - (string :tag "Tag"))) + (const :tag "ID parameter" id) + (const :tag "DIR parameter" dir) + (const :tag "Ask user" ask) + (const :tag "Don't create" nil))) (defcustom org-attach-method 'cp "The preferred method to attach a file. @@ -112,14 +114,24 @@ lns create a symbol link. Note that this is not supported :group 'org-attach :type 'boolean) -(defcustom org-attach-allow-inheritance t - "Non-nil means allow attachment directories be inherited." +(defcustom org-attach-use-inheritance 'selective + "Attachment inheritance for the outline. + +Enabling inheritance for org-attach implies two things. First, +that attachment links will look through all parent headings until +it finds the linked attachment. Second, that running org-attach +inside a node without attachments will make org-attach operate on +the first parent heading it finds with an attachment. + +Selective means to respect the inheritance setting in +`org-use-property-inheritance'." :group 'org-attach + :type '(choice + (const :tag "Don't use inheritance" nil) + (const :tag "Inherit parent node attachments" t) + (const :tag "Respect org-use-property-inheritance" selective)) :type 'boolean) -(defvar org-attach-inherited nil - "Indicates if the last access to the attachment directory was inherited.") - (defcustom org-attach-store-link-p nil "Non-nil means store a link to a file when attaching it." :group 'org-attach @@ -140,28 +152,108 @@ When set to `query', ask the user instead." (const :tag "Always delete attachments" t) (const :tag "Query the user" query))) -(defcustom org-attach-annex-auto-get 'ask - "Confirmation preference for automatically getting annex files. -If \\='ask, prompt using `y-or-n-p'. If t, always get. If nil, never get." +(defun org-attach-id-uuid-folder-format (id) + "Translate an UUID ID into a folder-path. +Default format for how Org translates ID properties to a path for +attachments. Useful if ID is generated with UUID." + (format "%s/%s" + (substring id 0 2) + (substring id 2))) + +(defun org-attach-id-ts-folder-format (id) + "Translate an ID based on a timestamp to a folder-path. +Useful way of translation if ID is generated based on ISO8601 +timestamp. Splits the attachment folder hierarchy into +year-month, the rest." + (format "%s/%s" + (substring id 0 6) + (substring id 6))) + +(defcustom org-attach-id-to-path-function-list '(org-attach-id-uuid-folder-format + org-attach-id-ts-folder-format) + "List of functions parsing an ID string into a folder-path. +The first function in this list defines the preferred function +which will be used when creating new attachment folders. All +functions of this list will be tried when looking for existing +attachment folders based on ID." :group 'org-attach - :package-version '(Org . "9.0") - :version "26.1" - :type '(choice - (const :tag "confirm with `y-or-n-p'" ask) - (const :tag "always get from annex if necessary" t) - (const :tag "never get from annex" nil))) + :package-version '(Org . "9.3") + :type '(repeat (function :tag "Function with ID as input"))) + +(defvar org-attach-after-change-hook nil + "Hook to be called when files have been added or removed to the attachment folder.") + +(defvar org-attach-open-hook nil + "Hook that is invoked by `org-attach-open'. + +Created mostly to be compatible with org-attach-git after removing +git-funtionality from this file.") + +(defcustom org-attach-commands + '(((?a ?\C-a) org-attach-attach + "Select a file and attach it to the task, using `org-attach-method'.") + ((?c ?\C-c) org-attach-attach-cp + "Attach a file using copy method.") + ((?m ?\C-m) org-attach-attach-mv + "Attach a file using move method.") + ((?l ?\C-l) org-attach-attach-ln + "Attach a file using link method.") + ((?y ?\C-y) org-attach-attach-lns + "Attach a file using symbolic-link method.") + ((?u ?\C-u) org-attach-url + "Attach a file from URL (downloading it).") + ((?b) org-attach-buffer + "Select a buffer and attach its contents to the task.") + ((?n ?\C-n) org-attach-new + "Create a new attachment, as an Emacs buffer.") + ((?z ?\C-z) org-attach-sync + "Synchronize the current node with its attachment\n directory, in case \ +you added attachments yourself.\n") + ((?o ?\C-o) org-attach-open + "Open current node's attachments.") + ((?O) org-attach-open-in-emacs + "Like \"o\", but force opening in Emacs.") + ((?f ?\C-f) org-attach-reveal + "Open current node's attachment directory. Create if missing.") + ((?F) org-attach-reveal-in-emacs + "Like \"f\", but force using Dired in Emacs.\n") + ((?d ?\C-d) org-attach-delete-one + "Delete one attachment, you will be prompted for a file name.") + ((?D) org-attach-delete-all + "Delete all of a node's attachments. A safer way is\n to open the \ +directory in dired and delete from there.\n") + ((?s ?\C-s) org-attach-set-directory + "Set a specific attachment directory for this entry. Sets DIR property.") + ((?S ?\C-S) org-attach-unset-directory + "Unset the attachment directory for this entry. Removes DIR property.") + ((?q) (lambda () (interactive) (message "Abort")) "Abort.")) + "The list of commands for the attachment dispatcher. +Each entry in this list is a list of three elements: +- A list of keys (characters) to select the command (the fist + character in the list is shown in the attachment dispatcher's + splash buffer and minubuffer prompt). +- A command that is called interactively when one of these keys + is pressed. +- A docstring for this command in the attachment dispatcher's + splash buffer." + :group 'org-attach + :package-version '(Org . "9.3") + :type '(repeat (list (repeat :tag "Keys" character) + (function :tag "Command") + (string :tag "Docstring")))) ;;;###autoload (defun org-attach () "The dispatcher for attachment commands. Shows a list of commands and prompts for another key to execute a command." (interactive) - (let (c marker) + (let ((dir (org-attach-dir nil 'no-fs-check)) + 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 task in current line"))) + (error "No item in current line"))) (save-excursion (when marker (set-buffer (marker-buffer marker)) @@ -171,200 +263,189 @@ Shows a list of commands and prompts for another key to execute a command." (save-window-excursion (unless org-attach-expert (with-output-to-temp-buffer "*Org Attach*" - (princ "Select an Attachment Command: - -a Select a file and attach it to the task, using `org-attach-method'. -c/m/l/y Attach a file using copy/move/link/symbolic-link method. -u Attach a file from URL (downloading it). -n Create a new attachment, as an Emacs buffer. -z Synchronize the current task with its attachment - directory, in case you added attachments yourself. - -o Open current task's attachments. -O Like \"o\", but force opening in Emacs. -f Open current task's attachment directory. -F Like \"f\", but force using dired in Emacs. - -d Delete one attachment, you will be prompted for a file name. -D Delete all of a task's attachments. A safer way is - to open the directory in dired and delete from there. - -s Set a specific attachment directory for this entry or reset to default. -i Make children of the current entry inherit its attachment directory."))) + (princ + (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*")) - (message "Select command: [acmlzoOfFdD]") + (message "Select command: [%s]" + (concat (mapcar #'caar org-attach-commands))) (setq c (read-char-exclusive)) (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*")))) - (cond - ((memq c '(?a ?\C-a)) (call-interactively 'org-attach-attach)) - ((memq c '(?c ?\C-c)) - (let ((org-attach-method 'cp)) (call-interactively 'org-attach-attach))) - ((memq c '(?m ?\C-m)) - (let ((org-attach-method 'mv)) (call-interactively 'org-attach-attach))) - ((memq c '(?l ?\C-l)) - (let ((org-attach-method 'ln)) (call-interactively 'org-attach-attach))) - ((memq c '(?y ?\C-y)) - (let ((org-attach-method 'lns)) (call-interactively 'org-attach-attach))) - ((memq c '(?u ?\C-u)) - (let ((org-attach-method 'url)) (call-interactively 'org-attach-url))) - ((memq c '(?n ?\C-n)) (call-interactively 'org-attach-new)) - ((memq c '(?z ?\C-z)) (call-interactively 'org-attach-sync)) - ((memq c '(?o ?\C-o)) (call-interactively 'org-attach-open)) - ((eq c ?O) (call-interactively 'org-attach-open-in-emacs)) - ((memq c '(?f ?\C-f)) (call-interactively 'org-attach-reveal)) - ((memq c '(?F)) (call-interactively 'org-attach-reveal-in-emacs)) - ((memq c '(?d ?\C-d)) (call-interactively - 'org-attach-delete-one)) - ((eq c ?D) (call-interactively 'org-attach-delete-all)) - ((eq c ?q) (message "Abort")) - ((memq c '(?s ?\C-s)) (call-interactively - 'org-attach-set-directory)) - ((memq c '(?i ?\C-i)) (call-interactively - 'org-attach-set-inherit)) - (t (error "No such attachment command %c" c)))))) - -(defun org-attach-dir (&optional create-if-not-exists-p) - "Return the directory associated with the current entry. -This first checks for a local property ATTACH_DIR, and then for an inherited -property ATTACH_DIR_INHERIT. If neither exists, the default mechanism -using the entry ID will be invoked to access the unique directory for the -current entry. -If the directory does not exist and CREATE-IF-NOT-EXISTS-P is non-nil, -the directory and (if necessary) the corresponding ID will be created." - (let (attach-dir uuid) - (setq org-attach-inherited (org-entry-get nil "ATTACH_DIR_INHERIT")) + (let ((command (cl-some (lambda (entry) + (and (memq c (nth 0 entry)) (nth 1 entry))) + org-attach-commands))) + (if (commandp command t) + (call-interactively command) + (error "No such attachment command: %c" c)))))) + +(defun org-attach-dir (&optional create-if-not-exists-p no-fs-check) + "Return the directory associated with the current outline node. +First check for DIR property, then ID property. +`org-attach-use-inheritance' determines whether inherited +properties also will be considered. + +If an ID property is found the default mechanism using that ID +will be invoked to access the directory for the current entry. +Note that this method returns the directory as declared by ID or +DIR even if the directory doesn't exist in the filesystem. + +If CREATE-IF-NOT-EXIST-P is non-nil, `org-attach-dir-get-create' +is run. If NO-FS-CHECK is non-nil, the function returns the path +to the attachment even if it has not yet been initialized in the +filesystem. + +If no attachment directory can be derived, return nil." + (let (attach-dir id) (cond - ((setq attach-dir (org-entry-get nil "ATTACH_DIR")) + (create-if-not-exists-p + (setq attach-dir (org-attach-dir-get-create))) + ((setq attach-dir (org-entry-get nil "DIR" org-attach-use-inheritance)) + (org-attach-check-absolute-path attach-dir)) + ;; Deprecated and removed from documentation, but still + ;; works. FIXME: Remove after major nr change. + ((setq attach-dir (org-entry-get nil "ATTACH_DIR" org-attach-use-inheritance)) (org-attach-check-absolute-path attach-dir)) - ((and org-attach-allow-inheritance - (org-entry-get nil "ATTACH_DIR_INHERIT" t)) - (setq attach-dir - (org-with-wide-buffer - (if (marker-position org-entry-property-inherited-from) - (goto-char org-entry-property-inherited-from) - (org-back-to-heading t)) - (let (org-attach-allow-inheritance) - (org-attach-dir create-if-not-exists-p)))) - (org-attach-check-absolute-path attach-dir) - (setq org-attach-inherited t)) - (t ; use the ID + ((setq id (org-entry-get nil "ID" org-attach-use-inheritance)) (org-attach-check-absolute-path nil) - (setq uuid (org-id-get (point) create-if-not-exists-p)) - (when (or uuid create-if-not-exists-p) - (unless uuid (error "ID retrieval/creation failed")) - (setq attach-dir (expand-file-name - (format "%s/%s" - (substring uuid 0 2) - (substring uuid 2)) - (expand-file-name org-attach-directory)))))) - (when attach-dir - (if (and create-if-not-exists-p - (not (file-directory-p attach-dir))) - (make-directory attach-dir t)) - (and (file-exists-p attach-dir) - attach-dir)))) + (setq attach-dir (org-attach-dir-from-id id 'try-all)))) + (if no-fs-check + attach-dir + (when (and attach-dir (file-directory-p attach-dir)) + attach-dir)))) + +(defun org-attach-dir-get-create () + "Return existing or new directory associated with the current outline node. +`org-attach-preferred-new-method' decides how to attach new +directory if neither ID nor DIR property exist. + +If the attachment by some reason cannot be created an error will be raised." + (interactive) + (let ((attach-dir (org-attach-dir nil 'no-fs-check))) + (unless attach-dir + (let (answer) + (when (eq org-attach-preferred-new-method 'ask) + (message "Create new ID [1] property or DIR [2] property for attachments?") + (setq answer (read-char-exclusive))) + (cond + ((or (eq org-attach-preferred-new-method 'id) (eq answer ?1)) + (setq attach-dir (org-attach-dir-from-id (org-id-get nil t)))) + ((or (eq org-attach-preferred-new-method 'dir) (eq answer ?2)) + (setq attach-dir (org-attach-set-directory))) + ((eq org-attach-preferred-new-method 'nil) + (error "No existing directory. DIR or ID property has to be explicitly created"))))) + (unless attach-dir + (error "No attachment directory is associated with the current node")) + (unless (file-directory-p attach-dir) + (make-directory attach-dir t)) + attach-dir)) + +(defun org-attach-dir-from-id (id &optional try-all) + "Returns a folder path based on `org-attach-id-dir' and ID. +If TRY-ALL is non-nil, try all id-to-path functions in +`org-attach-id-to-path-function-list' and return the first path +that exist in the filesystem, or the first one if none exist. +Otherwise only use the first function in that list." + (let ((attach-dir-preferred (expand-file-name + (funcall (car org-attach-id-to-path-function-list) id) + (expand-file-name org-attach-id-dir)))) + (if try-all + (let ((attach-dir attach-dir-preferred) + (fun-list (cdr org-attach-id-to-path-function-list))) + (while (and fun-list (not (file-directory-p attach-dir))) + (setq attach-dir (expand-file-name + (funcall (car fun-list) id) + (expand-file-name org-attach-id-dir))) + (setq fun-list (cdr fun-list))) + (if (file-directory-p attach-dir) + attach-dir + attach-dir-preferred)) + attach-dir-preferred))) (defun org-attach-check-absolute-path (dir) "Check if we have enough information to root the attachment directory. When DIR is given, check also if it is already absolute. Otherwise, -assume that it will be relative, and check if `org-attach-directory' is +assume that it will be relative, and check if `org-attach-id-dir' is absolute, or if at least the current buffer has a file name. Throw an error if we cannot root the directory." (or (and dir (file-name-absolute-p dir)) - (file-name-absolute-p org-attach-directory) + (file-name-absolute-p org-attach-id-dir) (buffer-file-name (buffer-base-buffer)) - (error "Need absolute `org-attach-directory' to attach in buffers without filename"))) + (error "Need absolute `org-attach-id-dir' to attach in buffers without filename"))) -(defun org-attach-set-directory (&optional arg) - "Set the ATTACH_DIR node property and ask to move files there. +(defun org-attach-set-directory () + "Set the DIR node property and ask to move files there. The property defines the directory that is used for attachments -of the entry. When called with `\\[universal-argument]', reset \ -the directory to -the default ID based one." - (interactive "P") +of the entry. Creates relative links if `org-attach-dir-relative' +is non-nil. + +Return the directory." + (interactive) (let ((old (org-attach-dir)) - (new - (progn - (if arg (org-entry-delete nil "ATTACH_DIR") - (let ((dir (read-directory-name - "Attachment directory: " - (org-entry-get nil - "ATTACH_DIR" - (and org-attach-allow-inheritance t))))) - (org-entry-put nil "ATTACH_DIR" dir))) - (org-attach-dir t)))) + (new + (let* ((attach-dir (read-directory-name + "Attachment directory: " + (org-entry-get nil "DIR"))) + (current-dir (file-name-directory (or default-directory + buffer-file-name))) + (attach-dir-relative (file-relative-name attach-dir current-dir))) + (org-entry-put nil "DIR" (if org-attach-dir-relative + attach-dir-relative + attach-dir)) + attach-dir))) (unless (or (string= old new) (not old)) (when (yes-or-no-p "Copy over attachments from old directory? ") + (copy-directory old new t t t)) + (when (yes-or-no-p (concat "Delete " old)) + (delete-directory old t))) + new)) + +(defun org-attach-unset-directory () + "Removes DIR node property. +If attachment folder is changed due to removal of DIR-property +ask to move attachments to new location and ask to delete old +attachment-folder. + +Change of attachment-folder due to unset might be if an ID +property is set on the node, or if a separate inherited +DIR-property exists (that is different than the unset one)." + (interactive) + (let ((old (org-attach-dir)) + (new + (progn + (org-entry-delete nil "DIR") + ;; ATTACH-DIR is deprecated and removed from documentation, + ;; but still works. Remove code for it after major nr change. + (org-entry-delete nil "ATTACH_DIR") + (org-attach-dir)))) + (unless (or (string= old new) + (not old)) + (when (and new (yes-or-no-p "Copy over attachments from old directory? ")) (copy-directory old new t nil t)) (when (yes-or-no-p (concat "Delete " old)) (delete-directory old t))))) -(defun org-attach-set-inherit () - "Set the ATTACH_DIR_INHERIT property of the current entry. -The property defines the directory that is used for attachments -of the entry and any children that do not explicitly define (by setting -the ATTACH_DIR property) their own attachment directory." - (interactive) - (org-entry-put nil "ATTACH_DIR_INHERIT" "t") - (message "Children will inherit attachment directory")) - -(defun org-attach-use-annex () - "Return non-nil if git annex can be used." - (let ((git-dir (vc-git-root (expand-file-name org-attach-directory)))) - (and org-attach-git-annex-cutoff - (or (file-exists-p (expand-file-name "annex" git-dir)) - (file-exists-p (expand-file-name ".git/annex" git-dir)))))) - -(defun org-attach-annex-get-maybe (path) - "Call git annex get PATH (via shell) if using git annex. -Signals an error if the file content is not available and it was not retrieved." - (let ((path-relative (file-relative-name path))) - (when (and (org-attach-use-annex) - (not - (string-equal - "found" - (shell-command-to-string - (format "git annex find --format=found --in=here %s" - (shell-quote-argument path-relative)))))) - (let ((should-get - (if (eq org-attach-annex-auto-get 'ask) - (y-or-n-p (format "Run git annex get %s? " path-relative)) - org-attach-annex-auto-get))) - (if should-get - (progn (message "Running git annex get \"%s\"." path-relative) - (call-process "git" nil nil nil "annex" "get" path-relative)) - (error "File %s stored in git annex but it is not available, and was not retrieved" - path)))))) - -(defun org-attach-commit () - "Commit changes to git if `org-attach-directory' is properly initialized. -This checks for the existence of a \".git\" directory in that directory." - (let* ((dir (expand-file-name org-attach-directory)) - (git-dir (vc-git-root dir)) - (use-annex (org-attach-use-annex)) - (changes 0)) - (when (and git-dir (executable-find "git")) - (with-temp-buffer - (cd dir) - (dolist (new-or-modified - (split-string - (shell-command-to-string - "git ls-files -zmo --exclude-standard") "\0" t)) - (if (and use-annex - (>= (file-attribute-size (file-attributes new-or-modified)) - org-attach-git-annex-cutoff)) - (call-process "git" nil nil nil "annex" "add" new-or-modified) - (call-process "git" nil nil nil "add" new-or-modified)) - (cl-incf changes)) - (dolist (deleted - (split-string - (shell-command-to-string "git ls-files -z --deleted") "\0" t)) - (call-process "git" nil nil nil "rm" deleted) - (cl-incf changes)) - (when (> changes 0) - (shell-command "git commit -m 'Synchronized attachments'")))))) - (defun org-attach-tag (&optional off) "Turn the autotag on or (if OFF is set) off." (when org-attach-auto-tag @@ -386,10 +467,25 @@ Only do this when `org-attach-store-link-p' is non-nil." (defun org-attach-url (url) (interactive "MURL of the file to attach: \n") - (org-attach-attach url)) + (let ((org-attach-method 'url)) + (org-attach-attach url))) + +(defun org-attach-buffer (buffer-name) + "Attach BUFFER-NAME's contents to current outline node. +BUFFER-NAME is a string. Signals a `file-already-exists' error +if it would overwrite an existing filename." + (interactive "bBuffer whose contents should be attached: ") + (let* ((attach-dir (org-attach-dir 'get-create)) + (output (expand-file-name buffer-name attach-dir))) + (when (file-exists-p output) + (signal 'file-already-exists (list "File exists" output))) + (run-hook-with-args 'org-attach-after-change-hook attach-dir) + (org-attach-tag) + (with-temp-file output + (insert-buffer-substring buffer-name)))) (defun org-attach-attach (file &optional visit-dir method) - "Move/copy/link FILE into the attachment directory of the current task. + "Move/copy/link FILE into the attachment directory of the current outline node. If VISIT-DIR is non-nil, visit the directory with dired. METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from `org-attach-method'." @@ -404,10 +500,7 @@ METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from nil)) (setq method (or method org-attach-method)) (let ((basename (file-name-nondirectory file))) - (when (and org-attach-file-list-property (not org-attach-inherited)) - (org-entry-add-to-multivalued-property - (point) org-attach-file-list-property basename)) - (let* ((attach-dir (org-attach-dir t)) + (let* ((attach-dir (org-attach-dir 'get-create)) (fname (expand-file-name basename attach-dir))) (cond ((eq method 'mv) (rename-file file fname)) @@ -415,8 +508,7 @@ METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from ((eq method 'ln) (add-name-to-file file fname)) ((eq method 'lns) (make-symbolic-link file fname)) ((eq method 'url) (url-copy-file file fname))) - (when org-attach-commit - (org-attach-commit)) + (run-hook-with-args 'org-attach-after-change-hook attach-dir) (org-attach-tag) (cond ((eq org-attach-store-link-p 'attached) (org-attach-store-link fname)) @@ -424,7 +516,7 @@ METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from (org-attach-store-link file))) (if visit-dir (dired attach-dir) - (message "File %S is now a task attachment." basename))))) + (message "File %S is now an attachment." basename))))) (defun org-attach-attach-cp () "Attach a file by copying it." @@ -449,13 +541,10 @@ On some systems, this apparently does copy the file instead." (let ((org-attach-method 'lns)) (call-interactively 'org-attach-attach))) (defun org-attach-new (file) - "Create a new attachment FILE for the current task. + "Create a new attachment FILE for the current outline node. The attachment is created as an Emacs buffer." (interactive "sCreate attachment named: ") - (when (and org-attach-file-list-property (not org-attach-inherited)) - (org-entry-add-to-multivalued-property - (point) org-attach-file-list-property file)) - (let ((attach-dir (org-attach-dir t))) + (let ((attach-dir (org-attach-dir 'get-create))) (org-attach-tag) (find-file (expand-file-name file attach-dir)) (message "New attachment %s" file))) @@ -463,7 +552,7 @@ The attachment is created as an Emacs buffer." (defun org-attach-delete-one (&optional file) "Delete a single attachment." (interactive) - (let* ((attach-dir (org-attach-dir t)) + (let* ((attach-dir (org-attach-dir)) (files (org-attach-file-list attach-dir)) (file (or file (completing-read @@ -475,44 +564,32 @@ The attachment is created as an Emacs buffer." (unless (file-exists-p file) (error "No such attachment: %s" file)) (delete-file file) - (when org-attach-commit - (org-attach-commit)))) + (run-hook-with-args 'org-attach-after-change-hook attach-dir))) (defun org-attach-delete-all (&optional force) - "Delete all attachments from the current task. + "Delete all attachments from the current outline node. This actually deletes the entire attachment directory. A safer way is to open the directory in dired and delete from there." (interactive "P") - (when (and org-attach-file-list-property (not org-attach-inherited)) - (org-entry-delete (point) org-attach-file-list-property)) (let ((attach-dir (org-attach-dir))) - (when - (and attach-dir - (or force - (y-or-n-p "Are you sure you want to remove all attachments of this entry? "))) - (shell-command (format "rm -fr %s" attach-dir)) + (when (and attach-dir + (or force + (yes-or-no-p "Really remove all attachments of this entry? "))) + (delete-directory attach-dir (yes-or-no-p "Recursive?") t) (message "Attachment directory removed") - (when org-attach-commit - (org-attach-commit)) + (run-hook-with-args 'org-attach-after-change-hook attach-dir) (org-attach-untag)))) (defun org-attach-sync () - "Synchronize the current tasks with its attachments. + "Synchronize the current outline node with its attachments. This can be used after files have been added externally." (interactive) - (when org-attach-commit - (org-attach-commit)) - (when (and org-attach-file-list-property (not org-attach-inherited)) - (org-entry-delete (point) org-attach-file-list-property)) (let ((attach-dir (org-attach-dir))) (when attach-dir + (run-hook-with-args 'org-attach-after-change-hook attach-dir) (let ((files (org-attach-file-list attach-dir))) - (org-attach-tag (not files)) - (when org-attach-file-list-property - (dolist (file files) - (unless (string-match "^\\.\\.?\\'" file) - (org-entry-add-to-multivalued-property - (point) org-attach-file-list-property file)))))))) + (org-attach-tag (not files)))) + (unless attach-dir (org-attach-tag t)))) (defun org-attach-file-list (dir) "Return a list of files in the attachment directory. @@ -521,35 +598,38 @@ This ignores files ending in \"~\"." (mapcar (lambda (x) (if (string-match "^\\.\\.?\\'" x) nil x)) (directory-files dir nil "[^~]\\'")))) -(defun org-attach-reveal (&optional if-exists) - "Show the attachment directory of the current task. -This will attempt to use an external program to show the directory." - (interactive "P") - (let ((attach-dir (org-attach-dir (not if-exists)))) - (and attach-dir (org-open-file attach-dir)))) +(defun org-attach-reveal () + "Show the attachment directory of the current outline node. +This will attempt to use an external program to show the +directory. Will create an attachment and folder if it doesn't +exist yet. Respects `org-attach-preferred-new-method'." + (interactive) + (org-open-file (org-attach-dir-get-create))) (defun org-attach-reveal-in-emacs () - "Show the attachment directory of the current task in dired." + "Show the attachment directory of the current outline node in dired. +Will create an attachment and folder if it doesn't exist yet. +Respects `org-attach-preferred-new-method'." (interactive) - (let ((attach-dir (org-attach-dir t))) - (dired attach-dir))) + (dired (org-attach-dir-get-create))) (defun org-attach-open (&optional in-emacs) - "Open an attachment of the current task. + "Open an attachment of the current outline node. If there are more than one attachment, you will be prompted for the file name. This command will open the file using the settings in `org-file-apps' and in the system-specific variants of this variable. If IN-EMACS is non-nil, force opening in Emacs." (interactive "P") - (let* ((attach-dir (org-attach-dir t)) - (files (org-attach-file-list attach-dir)) - (file (if (= (length files) 1) - (car files) - (completing-read "Open attachment: " - (mapcar #'list files) nil t))) - (path (expand-file-name file attach-dir))) - (org-attach-annex-get-maybe path) - (org-open-file path in-emacs))) + (let ((attach-dir (org-attach-dir))) + (if attach-dir + (let* ((file (pcase (org-attach-file-list attach-dir) + (`(,file) file) + (files (completing-read "Open attachment: " + (mapcar #'list files) nil t)))) + (path (expand-file-name file attach-dir))) + (run-hook-with-args 'org-attach-open-hook path) + (org-open-file path in-emacs)) + (error "No attachment directory exist")))) (defun org-attach-open-in-emacs () "Open attachment, force opening in Emacs. @@ -568,14 +648,114 @@ Basically, this adds the path to the attachment directory, and a \"file:\" prefix." (concat "file:" (org-attach-expand file))) +(org-link-set-parameters "attachment" + :follow #'org-attach-open-link + :export #'org-attach-export-link + :complete #'org-attach-complete-link) + +(defun org-attach-open-link (link &optional in-emacs) + "Attachment link type LINK is expanded with the attached directory and opened. + +With optional prefix argument IN-EMACS, Emacs will visit the file. +With a double \\[universal-argument] \\[universal-argument] \ +prefix arg, Org tries to avoid opening in Emacs +and to use an external application to visit the file." + (interactive "P") + (let (line search) + (cond + ((string-match "::\\([0-9]+\\)\\'" link) + (setq line (string-to-number (match-string 1 link)) + link (substring link 0 (match-beginning 0)))) + ((string-match "::\\(.+\\)\\'" link) + (setq search (match-string 1 link) + link (substring link 0 (match-beginning 0))))) + (if (string-match "[*?{]" (file-name-nondirectory link)) + (dired (org-attach-expand link)) + (org-open-file (org-attach-expand link) in-emacs line search)))) + +(defun org-attach-complete-link () + "Advise the user with the available files in the attachment directory." + (let ((attach-dir (org-attach-dir))) + (if attach-dir + (let* ((attached-dir (expand-file-name attach-dir)) + (file (read-file-name "File: " attached-dir)) + (pwd (file-name-as-directory attached-dir)) + (pwd-relative (file-name-as-directory + (abbreviate-file-name attached-dir)))) + (cond + ((string-match (concat "^" (regexp-quote pwd-relative) "\\(.+\\)") file) + (concat "attachment:" (match-string 1 file))) + ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") + (expand-file-name file)) + (concat "attachment:" (match-string 1 (expand-file-name file)))) + (t (concat "attachment:" file)))) + (error "No attachment directory exist")))) + +(defun org-attach-export-link (link description format) + "Translate attachment LINK from Org mode format to exported FORMAT. +Also includes the DESCRIPTION of the link in the export." + (save-excursion + (let (path desc) + (cond + ((string-match "::\\([0-9]+\\)\\'" link) + (setq link (substring link 0 (match-beginning 0)))) + ((string-match "::\\(.+\\)\\'" link) + (setq link (substring link 0 (match-beginning 0))))) + (setq path (file-relative-name (org-attach-expand link)) + desc (or description link)) + (pcase format + (`html (format "<a target=\"_blank\" href=\"%s\">%s</a>" path desc)) + (`latex (format "\\href{%s}{%s}" path desc)) + (`texinfo (format "@uref{%s,%s}" path desc)) + (`ascii (format "%s (%s)" desc path)) + (`md (format "[%s](%s)" desc path)) + (_ path))))) + (defun org-attach-archive-delete-maybe () "Maybe delete subtree attachments when archiving. This function is called by `org-archive-hook'. The option `org-attach-archive-delete' controls its behavior." - (when (if (eq org-attach-archive-delete 'query) - (yes-or-no-p "Delete all attachments? ") - org-attach-archive-delete) - (org-attach-delete-all t))) + (when org-attach-archive-delete + (org-attach-delete-all (not (eq org-attach-archive-delete 'query))))) + + +;; Attach from dired. + +;; Add the following lines to the config file to get a binding for +;; dired-mode. + +;; (add-hook +;; 'dired-mode-hook +;; (lambda () +;; (define-key dired-mode-map (kbd "C-c C-x a") #'org-attach-dired-to-subtree)))) + +;;;###autoload +(defun org-attach-dired-to-subtree (files) + "Attach FILES marked or current file in dired to subtree in other window. +Takes the method given in `org-attach-method' for the attach action. +Precondition: Point must be in a dired buffer. +Idea taken from `gnus-dired-attach'." + (interactive + (list (dired-get-marked-files))) + (unless (eq major-mode 'dired-mode) + (user-error "This command must be triggered in a dired buffer")) + (let ((start-win (selected-window)) + (other-win + (get-window-with-predicate + (lambda (window) + (with-current-buffer (window-buffer window) + (eq major-mode 'org-mode)))))) + (unless other-win + (user-error + "Can't attach to subtree. No window displaying an Org buffer")) + (select-window other-win) + (dolist (file files) + (org-attach-attach file)) + (select-window start-win) + (when (eq 'mv org-attach-method) + (revert-buffer)))) + + (add-hook 'org-archive-hook 'org-attach-archive-delete-maybe) diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el index 829872c3826..4f97e17ea3c 100644 --- a/lisp/org/org-capture.el +++ b/lisp/org/org-capture.el @@ -51,20 +51,32 @@ (require 'org) (declare-function org-at-encrypted-entry-p "org-crypt" ()) +(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-decrypt-entry "org-crypt" ()) +(declare-function org-element-at-point "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-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)) (declare-function org-table-analyze "org-table" ()) (declare-function org-table-current-dline "org-table" ()) +(declare-function org-table-fix-formulas "org-table" (key replace &optional limit delta remove)) (declare-function org-table-goto-line "org-table" (N)) +(defvar dired-buffers) (defvar org-end-time-was-given) (defvar org-remember-default-headline) (defvar org-remember-templates) -(defvar org-table-hlines) +(defvar org-store-link-plist) +(defvar org-table-border-regexp) (defvar org-table-current-begin-pos) -(defvar dired-buffers) +(defvar org-table-dataline-regexp) +(defvar org-table-fix-formulas-confirm) +(defvar org-table-hline-regexp) +(defvar org-table-hlines) (defvar org-capture-clock-was-started nil "Internal flag, noting if the clock was started.") @@ -263,6 +275,8 @@ properties are: capture was invoked, kill the buffer again after capture is finalized. + :no-save Do not save the target file after finishing the capture. + The template defines the text to be inserted. Often this is an Org mode entry (so the first line should start with a star) that will be filed as a child of the target headline. It can also be @@ -284,8 +298,10 @@ be replaced with content and expanded: with `org-capture-use-agenda-date' set. %T Time stamp as above, with date and time. %u, %U Like the above, but inactive time stamps. - %i Initial content, copied from the active region. If %i is - indented, the entire inserted text will be indented as well. + %i Initial content, copied from the active region. If + there is text before %i on the same line, such as + indentation, and %i is not inside a %(sexp), that prefix + will be added before every line in the inserted text. %a Annotation, normally the link created with `org-store-link'. %A Like %a, but prompt for the description part. %l Like %a, but only insert the literal link. @@ -474,37 +490,32 @@ this is necessary after initialization of the capture process, to avoid conflicts with other active capture processes." (plist-get (if local org-capture-current-plist org-capture-plist) prop)) -(defun org-capture-member (prop &optional local) - "Is PROP a property in `org-capture-plist'. -When LOCAL is set, use the local variable `org-capture-current-plist', -this is necessary after initialization of the capture process, -to avoid conflicts with other active capture processes." - (plist-get (if local org-capture-current-plist org-capture-plist) prop)) - ;;; The minor mode -(defvar org-capture-mode-map (make-sparse-keymap) +(defvar org-capture-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-c" #'org-capture-finalize) + (define-key map "\C-c\C-k" #'org-capture-kill) + (define-key map "\C-c\C-w" #'org-capture-refile) + map) "Keymap for `org-capture-mode', a minor mode. Use this map to set additional keybindings for when Org mode is used for a capture buffer.") (defvar org-capture-mode-hook nil - "Hook for the minor `org-capture-mode'.") + "Hook for the `org-capture-mode' minor mode.") (define-minor-mode org-capture-mode "Minor mode for special key bindings in a capture buffer. Turning on this mode runs the normal hook `org-capture-mode-hook'." - nil " Rem" org-capture-mode-map + nil " Cap" org-capture-mode-map (setq-local header-line-format (substitute-command-keys "\\<org-capture-mode-map>Capture buffer. Finish \ `\\[org-capture-finalize]', refile `\\[org-capture-refile]', \ abort `\\[org-capture-kill]'."))) -(define-key org-capture-mode-map "\C-c\C-c" 'org-capture-finalize) -(define-key org-capture-mode-map "\C-c\C-k" 'org-capture-kill) -(define-key org-capture-mode-map "\C-c\C-w" 'org-capture-refile) ;;; The main commands @@ -652,44 +663,38 @@ of the day at point (if any) or the current HH:MM time." :annotation annotation :initial initial :return-to-wconf (current-window-configuration) - :default-time - (or org-overriding-default-time - (org-current-time))) - (org-capture-set-target-location) + :default-time (or org-overriding-default-time + (org-current-time))) + (org-capture-set-target-location (and (equal goto 0) 'here)) (condition-case error (org-capture-put :template (org-capture-fill-template)) ((error quit) (if (get-buffer "*Capture*") (kill-buffer "*Capture*")) - (error "Capture abort: %s" error))) + (error "Capture abort: %s" (error-message-string error)))) (setq org-capture-clock-keep (org-capture-get :clock-keep)) - (if (equal goto 0) - ;;insert at point - (org-capture-insert-template-here) - (condition-case error - (org-capture-place-template - (eq (car (org-capture-get :target)) 'function)) - ((error quit) - (if (and (buffer-base-buffer (current-buffer)) + (condition-case error + (org-capture-place-template + (eq (car (org-capture-get :target)) 'function)) + ((error quit) + (when (and (buffer-base-buffer (current-buffer)) (string-prefix-p "CAPTURE-" (buffer-name))) - (kill-buffer (current-buffer))) - (set-window-configuration (org-capture-get :return-to-wconf)) - (error "Capture template `%s': %s" - (org-capture-get :key) - (nth 1 error)))) - (if (and (derived-mode-p 'org-mode) - (org-capture-get :clock-in)) - (condition-case nil - (progn - (if (org-clock-is-active) - (org-capture-put :interrupted-clock - (copy-marker org-clock-marker))) - (org-clock-in) - (setq-local org-capture-clock-was-started t)) - (error - "Could not start the clock in this capture buffer"))) - (if (org-capture-get :immediate-finish) - (org-capture-finalize))))))))) + (kill-buffer (current-buffer))) + (set-window-configuration (org-capture-get :return-to-wconf)) + (error "Capture template `%s': %s" + (org-capture-get :key) + (error-message-string error)))) + (when (and (derived-mode-p 'org-mode) (org-capture-get :clock-in)) + (condition-case nil + (progn + (when (org-clock-is-active) + (org-capture-put :interrupted-clock + (copy-marker org-clock-marker))) + (org-clock-in) + (setq-local org-capture-clock-was-started t)) + (error "Could not start the clock in this capture buffer"))) + (when (org-capture-get :immediate-finish) + (org-capture-finalize)))))))) (defun org-capture-get-template () "Get the template from a file or a function if necessary." @@ -743,9 +748,7 @@ captured item after finalizing." (org-with-point-at clock-in-task (org-clock-in))) (message "Interrupted clock has been resumed")))) - (let ((beg (point-min)) - (end (point-max)) - (abort-note nil)) + (let ((abort-note nil)) ;; Store the size of the capture buffer (org-capture-put :captured-entry-size (- (point-max) (point-min))) (widen) @@ -753,16 +756,11 @@ captured item after finalizing." (org-capture-put :insertion-point (point)) (if org-note-abort - (let ((m1 (org-capture-get :begin-marker 'local)) - (m2 (org-capture-get :end-marker 'local))) - (if (and m1 m2 (= m1 beg) (= m2 end)) - (progn - (setq m2 (if (cdr (assq 'heading org-blank-before-new-entry)) - m2 (1+ m2)) - m2 (if (< (point-max) m2) (point-max) m2)) - (setq abort-note 'clean) - (kill-region m1 m2)) - (setq abort-note 'dirty))) + (let ((beg (org-capture-get :begin-marker 'local)) + (end (org-capture-get :end-marker 'local))) + (if (not (and beg end)) (setq abort-note 'dirty) + (setq abort-note t) + (org-with-wide-buffer (kill-region beg end)))) ;; Postprocessing: Update Statistics cookies, do the sorting (when (derived-mode-p 'org-mode) @@ -774,9 +772,21 @@ captured item after finalizing." ;; If we have added a table line, maybe recompute? (when (and (eq (org-capture-get :type 'local) 'table-line) (org-at-table-p)) - (if (org-table-get-stored-formulas) - (org-table-recalculate 'all) ;; FIXME: Should we iterate??? - (org-table-align)))) + (if (not (org-table-get-stored-formulas)) (org-table-align) + ;; Adjust formulas, if necessary. We assume a non-nil + ;; `:immediate-finish' means that no confirmation is + ;; required. Else, obey `org-table-fix-formulas-confirm'. + ;; + ;; The delta required to fix formulas depends on the + ;; number of rows inserted by the template. + (when (or (org-capture-get :immediate-finish) + (not org-table-fix-formulas-confirm) + (funcall org-table-fix-formulas-confirm "Fix formulas? ")) + (org-table-fix-formulas + "@" nil (1- (org-table-current-dline)) + (count-lines (org-capture-get :begin-marker 'local) + (org-capture-get :end-marker 'local)))) + (org-table-recalculate 'all)))) ;FIXME: should we iterate? ;; Store this place as the last one where we stored something ;; Do the marking in the base buffer, so that it makes sense after ;; the indirect buffer has been killed. @@ -790,8 +800,8 @@ captured item after finalizing." (goto-char (org-capture-get :decrypted)) (org-encrypt-entry))) - ;; Kill the indirect buffer - (save-buffer) + (unless (org-capture-get :no-save) (save-buffer)) + (let ((return-wconf (org-capture-get :return-to-wconf 'local)) (new-buffer (org-capture-get :new-buffer 'local)) (kill-buffer (org-capture-get :kill-buffer 'local)) @@ -867,17 +877,15 @@ for `entry'-type templates")) ;; early. We want to wait for the refiling to be over, so we ;; control when the latter function is called. (org-capture-put :kill-buffer nil :jump-to-captured nil) - (unwind-protect - (progn - (org-capture-finalize) - (save-window-excursion - (with-current-buffer base - (org-with-wide-buffer - (goto-char pos) - (call-interactively 'org-refile)))) - (when kill-buffer (kill-buffer base)) - (when jump-to-captured (org-capture-goto-last-stored))) - (set-marker pos nil)))) + (org-capture-finalize) + (save-window-excursion + (with-current-buffer base + (org-with-point-at pos + (call-interactively 'org-refile)))) + (when kill-buffer + (with-current-buffer base (save-buffer)) + (kill-buffer base)) + (when jump-to-captured (org-capture-goto-last-stored)))) (defun org-capture-kill () "Abort the current capture process." @@ -915,6 +923,8 @@ Store them in the capture property list." (let ((target-entry-p t)) (save-excursion (pcase (or target (org-capture-get :target)) + (`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) @@ -1000,7 +1010,7 @@ Store them in the capture property list." (equal current-prefix-arg 1)) ;; Prompt for date. (let ((prompt-time (org-read-date - nil t nil "Date for tree entry:" nil))) + nil t nil "Date for tree entry:"))) (org-capture-put :default-time (cond ((and (or (not (boundp 'org-time-was-given)) @@ -1008,7 +1018,8 @@ Store them in the capture property list." (not (= (time-to-days prompt-time) (org-today)))) ;; Use 00:00 when no time is given for another ;; date than today? - (apply #'encode-time 0 0 0 + (apply #'encode-time 0 0 + org-extend-today-until (cl-cdddr (decode-time prompt-time)))) ((string-match "\\([^ ]+\\)--?[^ ]+[ ]+\\(.*\\)" org-read-date-final-answer) @@ -1026,7 +1037,7 @@ Store them in the capture property list." (org-today)))) ;; the following is the keep-restriction argument for ;; org-datetree-find-date-create - (if outline-path 'subtree-at-point)))) + (when outline-path 'subtree-at-point)))) (`(file+function ,path ,function) (set-buffer (org-capture-target-buffer path)) (org-capture-put-target-region-and-position) @@ -1095,7 +1106,7 @@ may have been stored before." (org-switch-to-buffer-other-window (org-capture-get-indirect-buffer (org-capture-get :buffer) "CAPTURE")) (widen) - (outline-show-all) + (org-show-all) (goto-char (org-capture-get :pos)) (setq-local outline-level 'org-outline-level) (pcase (org-capture-get :type) @@ -1109,11 +1120,16 @@ may have been stored before." (defun org-capture-place-entry () "Place the template as a new Org entry." - (let ((reversed? (org-capture-get :prepend)) + (let ((template (org-capture-get :template)) + (reversed? (org-capture-get :prepend)) + (exact-position (org-capture-get :exact-position)) + (insert-here? (org-capture-get :insert-here)) (level 1)) - (when (org-capture-get :exact-position) - (goto-char (org-capture-get :exact-position))) + (org-capture-verify-tree template) + (when exact-position (goto-char exact-position)) (cond + ;; Force insertion at point. + ((org-capture-get :insert-here) nil) ;; Insert as a child of the current entry. ((org-capture-get :target-entry-p) (setq level (org-get-valid-level @@ -1126,165 +1142,220 @@ may have been stored before." (unless (org-at-heading-p) (outline-next-heading))) ;; Otherwise, insert as a top-level entry at the end of the file. (t (goto-char (point-max)))) - (unless (bolp) (insert "\n")) - (org-capture-empty-lines-before) - (let ((beg (point)) - (template (org-capture-get :template))) - (org-capture-verify-tree template) - (org-paste-subtree level template 'for-yank) - (org-capture-empty-lines-after) - (org-capture-position-for-last-stored beg) - (unless (org-at-heading-p) (outline-next-heading)) - (let ((end (point))) - (org-capture-mark-kill-region beg end) - (org-capture-narrow beg end) - (when (or (re-search-backward "%\\?" beg t) - (re-search-forward "%\\?" end t)) - (replace-match "")))))) + (let ((origin (point))) + (unless (bolp) (insert "\n")) + (org-capture-empty-lines-before) + (let ((beg (point))) + (save-restriction + (when insert-here? (narrow-to-region beg beg)) + (org-paste-subtree level template 'for-yank)) + (org-capture-position-for-last-stored beg) + (let ((end (if (org-at-heading-p) (line-end-position 0) (point)))) + (org-capture-empty-lines-after) + (unless (org-at-heading-p) (outline-next-heading)) + (org-capture-mark-kill-region origin (point)) + (org-capture-narrow beg end) + (when (or (search-backward "%?" beg t) + (search-forward "%?" end t)) + (replace-match ""))))))) (defun org-capture-place-item () "Place the template as a new plain list item." - (let* ((txt (org-capture-get :template)) - (target-entry-p (org-capture-get :target-entry-p)) - (ind 0) - beg end) - (if (org-capture-get :exact-position) - (goto-char (org-capture-get :exact-position)) - (cond - ((not target-entry-p) - ;; Insert as top-level entry, either at beginning or at end of file - (setq beg (point-min) end (point-max))) - (t - (setq beg (1+ (point-at-eol)) - end (save-excursion (outline-next-heading) (point))))) - (setq ind nil) - (if (org-capture-get :prepend) - (progn - (goto-char beg) - (when (org-list-search-forward (org-item-beginning-re) end t) - (goto-char (match-beginning 0)) - (setq ind (org-get-indentation)))) - (goto-char end) - (when (org-list-search-backward (org-item-beginning-re) beg t) - (setq ind (org-get-indentation)) - (org-end-of-item))) - (unless ind (goto-char end))) - ;; Remove common indentation - (setq txt (org-remove-indentation txt)) - ;; Make sure this is indeed an item - (unless (string-match (concat "\\`" (org-item-re)) txt) - (setq txt (concat "- " - (mapconcat 'identity (split-string txt "\n") - "\n ")))) - ;; Prepare surrounding empty lines. - (unless (bolp) (insert "\n")) - (org-capture-empty-lines-before) - (setq beg (point)) - (unless (eolp) (save-excursion (insert "\n"))) - (unless ind - (org-indent-line) - (setq ind (org-get-indentation)) - (delete-region beg (point))) - ;; Set the correct indentation, depending on context - (setq ind (make-string ind ?\ )) - (setq txt (concat ind - (mapconcat 'identity (split-string txt "\n") - (concat "\n" ind)) - "\n")) - ;; Insert item. - (insert txt) - (org-capture-empty-lines-after) - (org-capture-position-for-last-stored beg) - (setq end (point)) - (org-capture-mark-kill-region beg end) - (org-capture-narrow beg end) - (if (or (re-search-backward "%\\?" beg t) - (re-search-forward "%\\?" end t)) - (replace-match "")))) + (let ((prepend? (org-capture-get :prepend)) + (template (org-remove-indentation (org-capture-get :template))) + item) + ;; Make template suitable for insertion. In particular, add + ;; a main bullet if it is missing. + (unless (string-match-p (concat "\\`" (org-item-re)) template) + (setq template (concat "- " (mapconcat #'identity + (split-string template "\n") + "\n ")))) + ;; Delimit the area where we should look for a plain list. + (pcase-let ((`(,beg . ,end) + (cond ((org-capture-get :exact-position) + ;; User gave a specific position. Start + ;; looking for lists from here. + (org-with-point-at (org-capture-get :exact-position) + (cons (line-beginning-position) + (if (org-capture-get :insert-here) + (line-beginning-position) + (org-entry-end-position))))) + ((org-capture-get :target-entry-p) + ;; At a heading, limit search to its body. + (cons (line-beginning-position 2) + (org-entry-end-position))) + (t + ;; Table is not necessarily under a heading. + ;; Search whole buffer. + (cons (point-min) (point-max)))))) + ;; Find the first plain list in the delimited area. + (goto-char beg) + (let ((item-regexp (org-item-beginning-re))) + (catch :found + (while (re-search-forward item-regexp end t) + (when (setq item (org-element-lineage + (org-element-at-point) '(plain-list) t)) + (goto-char (org-element-property (if prepend? :post-affiliated + :contents-end) + item)) + (throw :found t))) + ;; No list found. Move to the location when to insert + ;; template. Skip planning info and properties drawers, if + ;; any. + (goto-char (cond ((org-capture-get :insert-here) beg) + ((not prepend?) end) + ((org-before-first-heading-p) beg) + (t (max (save-excursion + (org-end-of-meta-data) + (point)) + beg))))))) + ;; Insert template. + (let ((origin (point))) + (unless (bolp) (insert "\n")) + ;; When a new list is created, always obey to `:empty-lines' and + ;; friends. + ;; + ;; When capturing in an existing list, do not change blank lines + ;; above or below the list; consider it to be a stable + ;; structure. However, we can control how many blank lines + ;; separate items. So obey to `:empty-lines' between items as + ;; long as it does not insert more than one empty line. In the + ;; specific case of empty lines above, it means we only obey the + ;; parameter when appending an item. + (unless (and item prepend?) + (org-capture-empty-lines-before + (and item + (not prepend?) + (min 1 (or (org-capture-get :empty-lines-before) + (org-capture-get :empty-lines) + 0))))) + (org-capture-position-for-last-stored (point)) + (let ((beg (line-beginning-position)) + (end (progn + (insert (org-trim template) "\n") + (point-marker)))) + (when item + (let ((i (save-excursion + (goto-char (org-element-property :post-affiliated item)) + (current-indentation)))) + (save-excursion + (goto-char beg) + (save-excursion + (while (< (point) end) + (indent-to i) + (forward-line))) + ;; Pre-pending an item could change the type of the list + ;; if there is a mismatch. In this situation, + ;; prioritize the existing list. + (when prepend? + (let ((ordered? (eq 'ordered (org-element-property :type item)))) + (when (org-xor ordered? + (string-match-p "\\`[A-Za-z0-9]\\([.)]\\)" + template)) + (org-cycle-list-bullet (if ordered? "1." "-"))))) + ;; Eventually repair the list for proper indentation and + ;; bullets. + (org-list-repair)))) + ;; Limit number of empty lines. See above for details. + (unless (and item (not prepend?)) + (org-capture-empty-lines-after + (and item + prepend? + (min 1 (or (org-capture-get :empty-lines-after) + (org-capture-get :empty-lines) + 0))))) + (org-capture-mark-kill-region origin (point)) + ;; ITEM always end with a newline character. Make sure we do + ;; not narrow at the beginning of the next line, possibly + ;; altering its structure (e.g., when it is a headline). + (org-capture-narrow beg (1- end)) + (when (or (search-backward "%?" beg t) + (search-forward "%?" end t)) + (replace-match "")))))) (defun org-capture-place-table-line () "Place the template as a table line." (require 'org-table) - (let* ((txt (org-capture-get :template)) - (target-entry-p (org-capture-get :target-entry-p)) - (table-line-pos (org-capture-get :table-line-pos)) - beg end) + (let ((text + (pcase (org-trim (org-capture-get :template)) + ((pred (string-match-p org-table-border-regexp)) + "| %?Bad template |") + (text (concat text "\n")))) + (table-line-pos (org-capture-get :table-line-pos)) + beg end) (cond ((org-capture-get :exact-position) - (goto-char (org-capture-get :exact-position))) - ((not target-entry-p) - ;; Table is not necessarily under a heading + (org-with-point-at (org-capture-get :exact-position) + (setq beg (line-beginning-position)) + (setq end (if (org-capture-get :insert-here) beg + (org-entry-end-position))))) + ((not (org-capture-get :target-entry-p)) + ;; Table is not necessarily under a heading. Find first table + ;; in the buffer. (setq beg (point-min) end (point-max))) (t - ;; WE are at a heading, limit search to the body - (setq beg (1+ (point-at-eol)) - end (save-excursion (outline-next-heading) (point))))) - (if (re-search-forward org-table-dataline-regexp end t) - (let ((b (org-table-begin)) (e (org-table-end)) (case-fold-search t)) - (goto-char e) - (if (looking-at "[ \t]*#\\+tblfm:") - (forward-line 1)) - (narrow-to-region b (point))) + ;; We are at a heading, limit search to the body. + (setq beg (line-beginning-position 2)) + (setq end (save-excursion (outline-next-heading) (point))))) + (goto-char beg) + ;; 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) + (`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) + (point)) + (throw :found t)))) + ;; No table found. Create it with an empty header. (goto-char end) - (insert "\n| |\n|----|\n| |\n") - (narrow-to-region (1+ end) (point))) - ;; We are narrowed to the table, or to an empty line if there was no table - - ;; Check if the template is good - (if (not (string-match org-table-dataline-regexp txt)) - (setq txt "| %?Bad template |\n")) - (if (functionp table-line-pos) - (setq table-line-pos (funcall table-line-pos)) - (setq table-line-pos (eval table-line-pos))) + (unless (bolp) (insert "\n")) + (let ((origin (point))) + (insert "| |\n|---|\n") + (narrow-to-region origin (point)))) + ;; In the current table, find the appropriate location for TEXT. (cond + ((org-capture-get :insert-here) nil) ((and table-line-pos - (string-match "\\(I+\\)\\([-+][0-9]\\)" table-line-pos)) + (string-match "\\(I+\\)\\([-+][0-9]+\\)" table-line-pos)) (goto-char (point-min)) - ;; we have a complex line specification - (let ((ll (ignore-errors - (save-match-data (org-table-analyze)) - (aref org-table-hlines - (- (match-end 1) (match-beginning 1))))) + (let ((line + (condition-case _ + (progn + (save-match-data (org-table-analyze)) + (aref org-table-hlines + (- (match-end 1) (match-beginning 1)))) + (error + (error "Invalid table line specification %S" table-line-pos)))) (delta (string-to-number (match-string 2 table-line-pos)))) - ;; The user wants a special position in the table - (unless ll - (error "Invalid table line specification \"%s\"" table-line-pos)) - (goto-char org-table-current-begin-pos) - (forward-line (+ ll delta (if (< delta 0) 0 -1))) - (org-table-insert-row 'below) - (beginning-of-line 1) - (delete-region (point) (1+ (point-at-eol))) - (setq beg (point)) - (insert txt) - (setq end (point)))) + (forward-line (+ line delta (if (< delta 0) 0 -1))) + (forward-line))) ;insert below ((org-capture-get :prepend) (goto-char (point-min)) - (re-search-forward org-table-hline-regexp nil t) - (beginning-of-line 1) - (re-search-forward org-table-dataline-regexp nil t) - (beginning-of-line 1) - (setq beg (point)) - (org-table-insert-row) - (beginning-of-line 1) - (delete-region (point) (1+ (point-at-eol))) - (insert txt) - (setq end (point))) + (cond + ((not (re-search-forward org-table-hline-regexp nil t))) + ((re-search-forward org-table-dataline-regexp nil t) (beginning-of-line)) + (t (goto-char (org-table-end))))) (t - (goto-char (point-max)) - (re-search-backward org-table-dataline-regexp nil t) - (beginning-of-line 1) - (org-table-insert-row 'below) - (beginning-of-line 1) - (delete-region (point) (1+ (point-at-eol))) - (setq beg (point)) - (insert txt) - (setq end (point)))) - (goto-char beg) - (org-capture-position-for-last-stored 'table-line) - (if (or (re-search-backward "%\\?" beg t) - (re-search-forward "%\\?" end t)) - (replace-match "")) - (org-table-align))) + (goto-char (org-table-end)))) + ;; Insert text and position point according to template. + (let ((origin (point))) + (unless (bolp) (insert "\n")) + (let ((beg (point)) + (end (save-excursion + (insert text) + (point)))) + (org-capture-position-for-last-stored 'table-line) + (org-capture-mark-kill-region origin end) + ;; TEXT is guaranteed to end with a newline character. Ignore + ;; it when narrowing so as to not alter data on the next line. + (org-capture-narrow beg (1- end)) + (when (or (search-backward "%?" beg t) + (search-forward "%?" end t)) + (replace-match "")))))) (defun org-capture-place-plain-text () "Place the template plainly. @@ -1292,35 +1363,36 @@ If the target locator points at an Org node, place the template into the text of the entry, before the first child. If not, place the template at the beginning or end of the file. Of course, if exact position has been required, just put it there." - (let* ((txt (org-capture-get :template)) - beg end) - (cond - ((org-capture-get :exact-position) - (goto-char (org-capture-get :exact-position))) - ((and (org-capture-get :target-entry-p) - (bolp) - (looking-at org-outline-regexp)) - ;; we should place the text into this entry - (if (org-capture-get :prepend) - ;; Skip meta data and drawers - (org-end-of-meta-data t) - ;; go to ent of the entry text, before the next headline - (outline-next-heading))) - (t - ;; beginning or end of file - (goto-char (if (org-capture-get :prepend) (point-min) (point-max))))) - (or (bolp) (newline)) + (cond + ((org-capture-get :exact-position) + (goto-char (org-capture-get :exact-position))) + ((org-capture-get :target-entry-p) + ;; Place the text into this entry. + (if (org-capture-get :prepend) + ;; Skip meta data and drawers. + (org-end-of-meta-data t) + ;; Go to end of the entry text, before the next headline. + (outline-next-heading))) + (t + ;; Beginning or end of file. + (goto-char (if (org-capture-get :prepend) (point-min) (point-max))))) + (let ((origin (point))) + (unless (bolp) (insert "\n")) (org-capture-empty-lines-before) - (setq beg (point)) - (insert txt) - (org-capture-empty-lines-after) - (org-capture-position-for-last-stored beg) - (setq end (point)) - (org-capture-mark-kill-region beg (1- end)) - (org-capture-narrow beg (1- end)) - (if (or (re-search-backward "%\\?" beg t) - (re-search-forward "%\\?" end t)) - (replace-match "")))) + (org-capture-position-for-last-stored (point)) + (let ((beg (point))) + (insert (org-capture-get :template)) + (unless (bolp) (insert "\n")) + ;; Ignore the final newline character so as to not alter data + ;; after inserted text. Yet, if the template is empty, make + ;; sure END matches BEG instead of pointing before it. + (let ((end (max beg (1- (point))))) + (org-capture-empty-lines-after) + (org-capture-mark-kill-region origin (point)) + (org-capture-narrow beg end) + (when (or (search-backward "%?" beg t) + (search-forward "%?" end t)) + (replace-match "")))))) (defun org-capture-mark-kill-region (beg end) "Mark the region that will have to be killed when aborting capture." @@ -1377,7 +1449,7 @@ Point will be after the empty lines, so insertion can directly be done." (let ((pos (point))) (org-back-over-empty-lines) (delete-region (point) pos) - (if (> n 0) (newline n)))) + (when (> n 0) (newline n)))) (defun org-capture-empty-lines-after (&optional n) "Set the correct number of empty lines after the inserted string. @@ -1387,49 +1459,11 @@ Point will remain at the first line after the inserted text." (org-back-over-empty-lines) (while (looking-at "[ \t]*\n") (replace-match "")) (let ((pos (point))) - (if (> n 0) (newline n)) + (when (> n 0) (newline n)) (goto-char pos))) (defvar org-clock-marker) ; Defined in org.el -(defun org-capture-insert-template-here () - "Insert the capture template at point." - (let* ((template (org-capture-get :template)) - (type (org-capture-get :type)) - beg end pp) - (unless (bolp) (insert "\n")) - (setq beg (point)) - (cond - ((and (eq type 'entry) (derived-mode-p 'org-mode)) - (org-capture-verify-tree (org-capture-get :template)) - (org-paste-subtree nil template t)) - ((and (memq type '(item checkitem)) - (derived-mode-p 'org-mode) - (save-excursion (skip-chars-backward " \t\n") - (setq pp (point)) - (org-in-item-p))) - (goto-char pp) - (org-insert-item) - (skip-chars-backward " ") - (skip-chars-backward "-+*0123456789).") - (delete-region (point) (point-at-eol)) - (setq beg (point)) - (org-remove-indentation template) - (insert template) - (org-capture-empty-lines-after) - (goto-char beg) - (org-list-repair) - (org-end-of-item)) - (t - (insert template) - (org-capture-empty-lines-after) - (skip-chars-forward " \t\n") - (unless (eobp) (beginning-of-line)))) - (setq end (point)) - (goto-char beg) - (when (re-search-forward "%\\?" end t) - (replace-match "")))) - (defun org-capture-set-plist (entry) "Initialize the property list from the template definition." (setq org-capture-plist (copy-sequence (nthcdr 5 entry))) @@ -1477,94 +1511,6 @@ Use PREFIX as a prefix for the name of the indirect buffer." (unless (org-kill-is-subtree-p tree) (error "Template is not a valid Org entry or tree"))) -(defun org-mks (table title &optional prompt specials) - "Select a member of an alist with multiple keys. - -TABLE is the alist which should contain entries where the car is a string. -There should be two types of entries. - -1. prefix descriptions like (\"a\" \"Description\") - This indicates that `a' is a prefix key for multi-letter selection, and - that there are entries following with keys like \"ab\", \"ax\"... - -2. Select-able members must have more than two elements, with the first - being the string of keys that lead to selecting it, and the second a - short description string of the item. - -The command will then make a temporary buffer listing all entries -that can be selected with a single key, and all the single key -prefixes. When you press the key for a single-letter entry, it is selected. -When you press a prefix key, the commands (and maybe further prefixes) -under this key will be shown and offered for selection. - -TITLE will be placed over the selection in the temporary buffer, -PROMPT will be used when prompting for a key. SPECIAL is an -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*")) - (prompt (or prompt "Select: ")) - current) - (unwind-protect - (catch 'exit - (while t - (erase-buffer) - (insert title "\n\n") - (let ((des-keys nil) - (allowed-keys '("\C-g")) - (cursor-type nil)) - ;; Populate allowed keys and descriptions keys - ;; available with CURRENT selector. - (let ((re (format "\\`%s\\(.\\)\\'" - (if current (regexp-quote current) ""))) - (prefix (if current (concat current " ") ""))) - (dolist (entry table) - (pcase entry - ;; Description. - (`(,(and key (pred (string-match re))) ,desc) - (let ((k (match-string 1 key))) - (push k des-keys) - (push k allowed-keys) - (insert prefix "[" k "]" "..." " " desc "..." "\n"))) - ;; Usable entry. - (`(,(and key (pred (string-match re))) ,desc . ,_) - (let ((k (match-string 1 key))) - (insert prefix "[" k "]" " " desc "\n") - (push k allowed-keys))) - (_ nil)))) - ;; Insert special entries, if any. - (when specials - (insert "----------------------------------------------------\ ----------------------------\n") - (pcase-dolist (`(,key ,description) specials) - (insert (format "[%s] %s\n" key description)) - (push key allowed-keys))) - ;; Display UI and let user select an entry or - ;; a sub-level prefix. - (goto-char (point-min)) - (unless (pos-visible-in-window-p (point-max)) - (org-fit-window-to-buffer)) - (message prompt) - (let ((pressed (char-to-string (read-char-exclusive)))) - (while (not (member pressed allowed-keys)) - (message "Invalid key `%s'" pressed) (sit-for 1) - (message prompt) - (setq pressed (char-to-string (read-char-exclusive)))) - (setq current (concat current pressed)) - (cond - ((equal pressed "\C-g") (user-error "Abort")) - ;; Selection is a prefix: open a new menu. - ((member pressed des-keys)) - ;; Selection matches an association: return it. - ((let ((entry (assoc current table))) - (and entry (throw 'exit entry)))) - ;; Selection matches a special entry: return the - ;; selection prefix. - ((assoc current specials) (throw 'exit current)) - (t (error "No entry available"))))))) - (when buffer (kill-buffer buffer)))))) - ;;; The template code (defun org-capture-select-template (&optional keys) "Select a capture template. @@ -1605,7 +1551,8 @@ The template may still contain \"%?\" for cursor positioning." (v-c (and kill-ring (current-kill 0))) (v-x (or (org-get-x-clipboard 'PRIMARY) (org-get-x-clipboard 'CLIPBOARD) - (org-get-x-clipboard 'SECONDARY))) + (org-get-x-clipboard 'SECONDARY) + "")) ;ensure it is a string ;; `initial' and `annotation' might have been passed. But if ;; the property list has them, we prefer those values. (v-i (or (plist-get org-store-link-plist :initial) @@ -1624,14 +1571,14 @@ The template may still contain \"%?\" for cursor positioning." (replace-match "[[\\1][%^{Link description}]]" nil nil v-a) v-a)) (v-l (if (and v-a (string-match l-re v-a)) - (replace-match "\\1" nil nil v-a) + (replace-match "[[\\1]]" nil nil v-a) v-a)) (v-n user-full-name) (v-k (if (marker-buffer org-clock-marker) (org-no-properties org-clock-heading) "")) (v-K (if (marker-buffer org-clock-marker) - (org-make-link-string + (org-link-make-string (format "%s::*%s" (buffer-file-name (marker-buffer org-clock-marker)) v-k) @@ -1646,10 +1593,8 @@ The template may still contain \"%?\" for cursor positioning." (org-get-x-clipboard 'CLIPBOARD) (org-get-x-clipboard 'SECONDARY) v-c)))) - (setq org-store-link-plist (plist-put org-store-link-plist :annotation v-a)) (setq org-store-link-plist (plist-put org-store-link-plist :initial v-i)) - (unless template (setq template "") (message "no template") (ding) @@ -1661,7 +1606,6 @@ The template may still contain \"%?\" for cursor positioning." (setq mark-active nil) (insert template) (goto-char (point-min)) - ;; %[] insert contents of a file. (save-excursion (while (re-search-forward "%\\[\\(.+\\)\\]" nil t) @@ -1678,10 +1622,8 @@ The template may still contain \"%?\" for cursor positioning." (insert (format "%%![couldn not insert %s: %s]" filename error)))))))) - ;; Mark %() embedded elisp for later evaluation. (org-capture-expand-embedded-elisp 'mark) - ;; Expand non-interactive templates. (let ((regexp "%\\(:[-A-Za-z]+\\|<\\([^>\n]+\\)>\\|[aAcfFikKlntTuUx]\\)")) (save-excursion @@ -1709,11 +1651,9 @@ The template may still contain \"%?\" for cursor positioning." ;; Outside embedded Lisp, repeat leading ;; characters before initial place holder ;; every line. - (let ((lead (buffer-substring-no-properties - (line-beginning-position) (point)))) - (replace-regexp-in-string "\n\\(.\\)" - (concat lead "\\1") - v-i nil nil 1)))) + (let ((lead (concat "\n" + (org-current-line-string t)))) + (replace-regexp-in-string "\n" lead v-i nil t)))) (?a v-a) (?A v-A) (?c v-c) @@ -1733,10 +1673,8 @@ The template may still contain \"%?\" for cursor positioning." ;; Escape sensitive characters. (replace-regexp-in-string "[\\\"]" "\\\\\\&" replacement) replacement)))))))) - ;; Expand %() embedded Elisp. Limit to Sexp originally marked. (org-capture-expand-embedded-elisp) - ;; Expand interactive templates. This is the last step so that ;; template is mostly expanded when prompting happens. Turn on ;; Org mode and set local variables. This is to support @@ -1782,9 +1720,7 @@ The template may still contain \"%?\" for cursor positioning." (unless (eq (char-before) ?:) (insert ":")) (insert ins) (unless (eq (char-after) ?:) (insert ":")) - (and (org-at-heading-p) - (let ((org-ignore-region t)) - (org-set-tags nil 'align)))))) + (when (org-at-heading-p) (org-align-tags))))) ((or "C" "L") (let ((insert-fun (if (equal key "C") #'insert (lambda (s) (org-insert-link 0 s))))) @@ -1799,7 +1735,36 @@ The template may still contain \"%?\" for cursor positioning." first-value))) (_ (error "Invalid `org-capture--clipboards' value: %S" org-capture--clipboards))))) - ("p" (org-set-property prompt nil)) + ("p" + ;; We remove file properties inherited from + ;; target buffer so `org-read-property-value' has + ;; a chance to find allowed values in sub-trees + ;; from the target buffer. + (setq-local org-file-properties nil) + (let* ((origin (set-marker (make-marker) + (org-capture-get :pos) + (org-capture-get :buffer))) + ;; Find location from where to get allowed + ;; values. If `:target-entry-p' is + ;; non-nil, the current headline in the + ;; target buffer is going to be a parent + ;; headline, so location is fine. + ;; Otherwise, find the parent headline in + ;; the target buffer. + (pom (if (org-capture-get :target-entry-p) origin + (let ((level (progn + (while (org-up-heading-safe)) + (org-current-level)))) + (org-with-point-at origin + (let ((l (if (org-at-heading-p) + (org-current-level) + most-positive-fixnum))) + (while (and l (>= l level)) + (setq l (org-up-heading-safe))) + (if l (point-marker) + (point-min-marker))))))) + (value (org-read-property-value prompt pom))) + (org-set-property prompt value))) ((or "t" "T" "u" "U") ;; These are the date/time related ones. (let* ((upcase? (equal (upcase key) key)) @@ -1827,7 +1792,6 @@ The template may still contain \"%?\" for cursor positioning." (_ (error "Unknown template placeholder: \"%%^%s\"" key)))))))) - ;; Replace %n escapes with nth %^{...} string. (setq strings (nreverse strings)) (save-excursion @@ -1836,16 +1800,16 @@ The template may still contain \"%?\" for cursor positioning." (replace-match (nth (1- (string-to-number (match-string 1))) strings) nil t))))) - ;; Make sure there are no empty lines before the text, and that - ;; it ends with a newline character. + ;; it ends with a newline character or it is empty. (skip-chars-forward " \t\n") (delete-region (point-min) (line-beginning-position)) (goto-char (point-max)) (skip-chars-backward " \t\n") - (delete-region (point) (point-max)) - (insert "\n") - + (if (bobp) (delete-region (point) (line-end-position)) + (end-of-line) + (delete-region (point) (point-max)) + (insert "\n")) ;; Return the expanded template and kill the capture buffer. (untabify (point-min) (point-max)) (set-buffer-modified-p nil) @@ -1952,9 +1916,9 @@ Assume sexps have been marked with (setq jump-to-captured t)) (append (list key desc type target template) - (if prepend '(:prepend t)) - (if immediate '(:immediate-finish t)) - (if jump-to-captured '(:jump-to-captured t))))) + (and prepend '(:prepend t)) + (and immediate '(:immediate-finish t)) + (and jump-to-captured '(:jump-to-captured t))))) org-remember-templates)))) diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index 9046661b266..df4ba62425b 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -35,12 +35,17 @@ (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-link-display-format "ol" (s)) +(declare-function org-link-heading-search-string "ol" (&optional string)) +(declare-function org-link-make-string "ol" (link &optional description)) (declare-function org-table-goto-line "org-table" (n)) +(declare-function org-dynamic-block-define "org" (type func)) -(defvar org-frame-title-format-backup frame-title-format) +(defvar org-frame-title-format-backup nil) +(defvar org-state) +(defvar org-link-bracket-re) (defvar org-time-stamp-formats) - (defgroup org-clock nil "Options concerning clocking working time in Org mode." :tag "Org Clock" @@ -156,7 +161,10 @@ state to switch it to." (symbol :tag "Function"))) (defcustom org-clock-history-length 5 - "Number of clock tasks to remember in history." + "Number of clock tasks to remember in history. +Clocking in using history works best if this is at most 35, in +which case all digits and capital letters are used up by the +*Clock Task Select* buffer." :group 'org-clock :type 'integer) @@ -294,10 +302,12 @@ string as argument." :stepskip0 nil :fileskip0 nil :tags nil + :match nil :emphasize nil :link nil :narrow '40! :indent t + :hidefiles nil :formula nil :timestamp nil :level nil @@ -328,11 +338,12 @@ For more information, see `org-clocktable-write-default'." :version "24.1" :type 'alist) -(defcustom org-clock-clocktable-default-properties '(:maxlevel 2 :scope file) +(defcustom org-clock-clocktable-default-properties '(:maxlevel 2) "Default properties for new clocktables. These will be inserted into the BEGIN line, to make it easy for users to play with them." :group 'org-clocktable + :package-version '(Org . "9.2") :type 'plist) (defcustom org-clock-idle-time nil @@ -518,8 +529,7 @@ cannot be translated." (cond ((functionp org-clock-heading-function) (funcall org-clock-heading-function)) ((org-before-first-heading-p) "???") - (t (replace-regexp-in-string - org-bracket-link-analytic-regexp "\\5" + (t (org-link-display-format (org-no-properties (org-get-heading t t t t)))))) (defun org-clock-menu () @@ -533,7 +543,7 @@ cannot be translated." (defun org-clock-history-push (&optional pos buffer) "Push a marker to the clock history." - (setq org-clock-history-length (max 1 (min 35 org-clock-history-length))) + (setq org-clock-history-length (max 1 org-clock-history-length)) (let ((m (move-marker (make-marker) (or pos (point)) (org-base-buffer (or buffer (current-buffer))))) @@ -723,7 +733,8 @@ menu\nmouse-2 will jump to task")) The time returned includes the time spent on this task in previous clocking intervals." (let ((currently-clocked-time - (floor (time-convert (time-since org-clock-start-time) 'integer) + (floor (org-time-convert-to-integer + (org-time-since org-clock-start-time)) 60))) (+ currently-clocked-time (or org-clock-total-time 0)))) @@ -732,8 +743,8 @@ previous clocking intervals." VALUE can be a number of minutes, or a string with format hh:mm or mm. When the string starts with a + or a - sign, the current value of the effort property will be changed by that amount. If the effort value is expressed -as an `org-effort-durations' (e.g. \"3h\"), the modified value will be -converted to a hh:mm duration. +as an unit defined in `org-duration-units' (e.g. \"3h\"), the modified +value will be converted to a hh:mm duration. This command will update the \"Effort\" property of the currently clocked item, and the value displayed in the mode line." @@ -913,47 +924,52 @@ If necessary, clock-out of the currently active clock." (defvar org-clock-resolving-clocks nil) (defvar org-clock-resolving-clocks-due-to-idleness nil) -(defun org-clock-resolve-clock (clock resolve-to clock-out-time - &optional close-p restart-p fail-quietly) - "Resolve `CLOCK' given the time `RESOLVE-TO', and the present. -`CLOCK' is a cons cell of the form (MARKER START-TIME)." - (let ((org-clock-resolving-clocks t)) - (cond - ((null resolve-to) - (org-clock-clock-cancel clock) - (if (and restart-p (not org-clock-clocking-in)) - (org-clock-clock-in clock))) - - ((eq resolve-to 'now) - (if restart-p - (error "RESTART-P is not valid here")) - (if (or close-p org-clock-clocking-in) - (org-clock-clock-out clock fail-quietly) - (unless (org-is-active-clock clock) - (org-clock-clock-in clock t)))) - - ((not (time-less-p resolve-to nil)) - (error "RESOLVE-TO must refer to a time in the past")) - - (t - (if restart-p - (error "RESTART-P is not valid here")) - (org-clock-clock-out clock fail-quietly (or clock-out-time - resolve-to)) - (unless org-clock-clocking-in - (if close-p - (setq org-clock-leftover-time (and (null clock-out-time) - resolve-to)) - (org-clock-clock-in clock nil (and clock-out-time - resolve-to)))))))) +(defun org-clock-resolve-clock + (clock resolve-to clock-out-time close restart fail-quietly) + "Resolve CLOCK given the time RESOLVE-TO, and the present. +CLOCK is a cons cell of the form (MARKER START-TIME)." + (let ((org-clock-resolving-clocks t) + ;; If the clocked entry contained only a clock and possibly + ;; the associated drawer, and we either cancel it or clock it + ;; out, `org-clock-out-remove-zero-time-clocks' may clear all + ;; contents, and leave point on the /next/ headline. We store + ;; the current entry location to be able to get back here when + ;; we need to clock in again the previously clocked task. + (heading (org-with-point-at (car clock) + (org-back-to-heading t) + (point-marker)))) + (pcase resolve-to + (`nil + (org-clock-clock-cancel clock) + (when (and restart (not org-clock-clocking-in)) + (org-with-point-at heading (org-clock-in)))) + (`now + (cond + (restart (error "RESTART is not valid here")) + ((or close org-clock-clocking-in) + (org-clock-clock-out clock fail-quietly)) + ((org-is-active-clock clock) nil) + (t (org-clock-clock-in clock t)))) + ((pred (org-time-less-p nil)) + (error "RESOLVE-TO must refer to a time in the past")) + (_ + (when restart (error "RESTART is not valid here")) + (org-clock-clock-out clock fail-quietly (or clock-out-time resolve-to)) + (cond + (org-clock-clocking-in nil) + (close + (setq org-clock-leftover-time (and (null clock-out-time) resolve-to))) + (t + (org-with-point-at heading + (org-clock-in nil (and clock-out-time resolve-to))))))))) (defun org-clock-jump-to-current-clock (&optional effective-clock) - (interactive) + "When an Org clock is running, jump to it." (let ((drawer (org-clock-into-drawer)) (clock (or effective-clock (cons org-clock-marker org-clock-start-time)))) (unless (marker-buffer (car clock)) - (error "No clock is currently running")) + (user-error "No Org clock is currently running")) (org-with-clock clock (org-clock-goto)) (with-current-buffer (marker-buffer (car clock)) (goto-char (car clock)) @@ -1033,7 +1049,7 @@ to be CLOCKED OUT.")))) nil 45))) (and (not (memq char-pressed '(?i ?q))) char-pressed))))) (default - (floor (time-convert (time-since last-valid) 'integer) + (floor (org-time-convert-to-integer (org-time-since last-valid)) 60)) (keep (and (memq ch '(?k ?K)) @@ -1042,8 +1058,8 @@ to be CLOCKED OUT.")))) (and (memq ch '(?g ?G)) (read-number "Got back how many minutes ago? " default))) (subtractp (memq ch '(?s ?S))) - (barely-started-p (time-less-p - (time-subtract last-valid (cdr clock)) + (barely-started-p (org-time-less-p + (org-time-subtract last-valid (cdr clock)) 45)) (start-over (and subtractp barely-started-p))) (cond @@ -1070,9 +1086,9 @@ to be CLOCKED OUT.")))) (and gotback (= gotback default))) 'now) (keep - (time-add last-valid (* 60 keep))) + (org-time-add last-valid (* 60 keep))) (gotback - (time-since (* 60 gotback))) + (org-time-since (* 60 gotback))) (t (error "Unexpected, please report this as a bug"))) (and gotback last-valid) @@ -1102,9 +1118,9 @@ If `only-dangling-p' is non-nil, only ask to resolve dangling (lambda (clock) (format "Dangling clock started %d mins ago" - (floor (time-convert (time-since (cdr clock)) - 'integer) - 60))))) + (floor (org-time-convert-to-integer + (org-time-since (cdr clock))) + 60))))) (or last-valid (cdr clock))))))))))) @@ -1154,7 +1170,7 @@ so long." org-clock-marker (marker-buffer org-clock-marker)) (let* ((org-clock-user-idle-seconds (org-user-idle-seconds)) (org-clock-user-idle-start - (time-since org-clock-user-idle-seconds)) + (org-time-since org-clock-user-idle-seconds)) (org-clock-resolving-clocks-due-to-idleness t)) (if (> org-clock-user-idle-seconds (* 60 org-clock-idle-time)) (org-clock-resolve @@ -1216,33 +1232,27 @@ the default behavior." (throw 'abort nil))) (when (equal select '(4)) - (setq selected-task (org-clock-select-task "Clock-in on task: ")) - (if selected-task - (setq selected-task (copy-marker selected-task)) - (error "Abort"))) + (pcase (org-clock-select-task "Clock-in on task: ") + (`nil (error "Abort")) + (task (setq selected-task (copy-marker task))))) (when (equal select '(16)) ;; Mark as default clocking task (org-clock-mark-default-task)) (when interrupting - ;; We are interrupting the clocking of a different task. - ;; Save a marker to this task, so that we can go back. - ;; First check if we are trying to clock into the same task! - (when (save-excursion - (unless selected-task - (org-back-to-heading t)) - (and (equal (marker-buffer org-clock-hd-marker) - (if selected-task - (marker-buffer selected-task) - (current-buffer))) - (= (marker-position org-clock-hd-marker) - (if selected-task - (marker-position selected-task) - (point))) - (equal org-clock-current-task (nth 4 (org-heading-components))))) - (message "Clock continues in \"%s\"" org-clock-heading) - (throw 'abort nil)) + ;; We are interrupting the clocking of a different task. Save + ;; a marker to this task, so that we can go back. First check + ;; if we are trying to clock into the same task! + (when (or selected-task (derived-mode-p 'org-mode)) + (org-with-point-at selected-task + (unless selected-task (org-back-to-heading t)) + (when (and (eq (marker-buffer org-clock-hd-marker) + (org-base-buffer (current-buffer))) + (= (point) (marker-position org-clock-hd-marker)) + (equal org-clock-current-task (org-get-heading t t t t))) + (message "Clock continues in %S" org-clock-heading) + (throw 'abort nil)))) (move-marker org-clock-interrupted-task (marker-position org-clock-marker) (marker-buffer org-clock-marker)) @@ -1267,7 +1277,7 @@ the default behavior." (or interrupting (move-marker org-clock-interrupted-task nil)) (run-hooks 'org-clock-in-prepare-hook) (org-clock-history-push) - (setq org-clock-current-task (nth 4 (org-heading-components))) + (setq org-clock-current-task (org-get-heading t t t t)) (cond ((functionp org-clock-in-switch-to-state) (let ((case-fold-search nil)) (looking-at org-complex-heading-regexp)) @@ -1310,7 +1320,7 @@ the default behavior." (end-of-line 0) (org-in-item-p))) (beginning-of-line 1) - (indent-line-to (- (org-get-indentation) 2))) + (indent-line-to (- (current-indentation) 2))) (insert org-clock-string " ") (setq org-clock-effort (org-entry-get (point) org-effort-property)) (setq org-clock-total-time (org-clock-sum-current-item @@ -1321,11 +1331,10 @@ the default behavior." (y-or-n-p (format "You stopped another clock %d mins ago; start this one from then? " - (/ (time-convert - (time-subtract + (/ (org-time-convert-to-integer + (org-time-subtract (org-current-time org-clock-rounding-minutes t) - leftover) - 'integer) + leftover)) 60))) leftover) start-time @@ -1347,6 +1356,7 @@ the default behavior." ;; add to frame title (when (or (eq org-clock-clocked-in-display 'frame-title) (eq org-clock-clocked-in-display 'both)) + (setq org-frame-title-format-backup frame-title-format) (setq frame-title-format org-clock-frame-title-format)) (org-clock-update-mode-line) (when org-clock-mode-line-timer @@ -1501,9 +1511,9 @@ line and position cursor in that line." (let ((beg (point))) (insert ":" drawer ":\n:END:\n") (org-indent-region beg (point)) - (goto-char beg) - (org-flag-drawer t) - (forward-line)))) + (org-flag-region + (line-end-position -1) (1- (point)) t 'org-hide-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 ;; all clocks in the section and wrap them within the drawer. @@ -1527,7 +1537,7 @@ line and position cursor in that line." (let ((end (point-marker))) (goto-char beg) (save-excursion (insert ":" drawer ":\n")) - (org-flag-drawer t) + (org-flag-region (line-end-position) (1- end) t 'org-hide-drawer) (org-indent-region (point) end) (forward-line) (unless org-log-states-order-reversed @@ -1537,6 +1547,14 @@ line and position cursor in that line." (org-log-states-order-reversed (goto-char (car (last positions)))) (t (goto-char (car positions)))))))) +(defun org-clock-restore-frame-title-format () + "Restore `frame-title-format' from `org-frame-title-format-backup'. +`frame-title-format' is restored if `org-frame-title-format-backup' is not nil +and current `frame-title-format' is equal to `org-clock-frame-title-format'." + (when (and org-frame-title-format-backup + (equal frame-title-format org-clock-frame-title-format)) + (setq frame-title-format org-frame-title-format-backup))) + ;;;###autoload (defun org-clock-out (&optional switch-to-state fail-quietly at-time) "Stop the currently running clock. @@ -1548,7 +1566,7 @@ to, overriding the existing value of `org-clock-out-switch-to-state'." (when (not (org-clocking-p)) (setq global-mode-string (delq 'org-mode-line-string global-mode-string)) - (setq frame-title-format org-frame-title-format-backup) + (org-clock-restore-frame-title-format) (force-mode-line-update) (if fail-quietly (throw 'exit t) (user-error "No active clock"))) (let ((org-clock-out-switch-to-state @@ -1576,10 +1594,10 @@ to, overriding the existing value of `org-clock-out-switch-to-state'." (delete-region (point) (point-at-eol)) (insert "--") (setq te (org-insert-time-stamp (or at-time now) 'with-hm 'inactive)) - (setq s (time-convert (time-subtract - (org-time-string-to-time te) - (org-time-string-to-time ts)) - 'integer) + (setq s (org-time-convert-to-integer + (time-subtract + (org-time-string-to-time te) + (org-time-string-to-time ts))) h (floor s 3600) m (floor (mod s 3600) 60)) (insert " => " (format "%2d:%02d" h m)) @@ -1604,7 +1622,7 @@ to, overriding the existing value of `org-clock-out-switch-to-state'." (setq org-clock-idle-timer nil)) (setq global-mode-string (delq 'org-mode-line-string global-mode-string)) - (setq frame-title-format org-frame-title-format-backup) + (org-clock-restore-frame-title-format) (when org-clock-out-switch-to-state (save-excursion (org-back-to-heading t) @@ -1704,7 +1722,7 @@ Optional argument N tells to change by that many units." (when (not (org-clocking-p)) (setq global-mode-string (delq 'org-mode-line-string global-mode-string)) - (setq frame-title-format org-frame-title-format-backup) + (org-clock-restore-frame-title-format) (force-mode-line-update) (error "No active clock")) (save-excursion ; Do not replace this with `with-current-buffer'. @@ -1718,9 +1736,10 @@ Optional argument N tells to change by that many units." (sit-for 2))) (move-marker org-clock-marker nil) (move-marker org-clock-hd-marker nil) + (setq org-clock-current-task nil) (setq global-mode-string (delq 'org-mode-line-string global-mode-string)) - (setq frame-title-format org-frame-title-format-backup) + (org-clock-restore-frame-title-format) (force-mode-line-update) (message "Clock canceled") (run-hooks 'org-clock-cancel-hook)) @@ -1747,7 +1766,6 @@ With prefix arg SELECT, offer recently clocked tasks for selection." (goto-char m) (org-show-entry) (org-back-to-heading t) - (org-cycle-hide-drawers 'children) (recenter org-clock-goto-before-context) (org-reveal) (if recent @@ -1786,88 +1804,87 @@ HEADLINE-FILTER is a zero-arg function that, if specified, is called for each headline in the time range with point at the headline. Headlines for which HEADLINE-FILTER returns nil are excluded from the clock summation. PROPNAME lets you set a custom text property instead of :org-clock-minutes." - (org-with-silent-modifications - (let* ((re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*" - org-clock-string - "[ \t]*\\(?:\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)\\|=>[ \t]+\\([0-9]+\\):\\([0-9]+\\)\\)")) - (lmax 30) - (ltimes (make-vector lmax 0)) - (level 0) - (tstart (cond ((stringp tstart) (org-time-string-to-seconds tstart)) - ((consp tstart) (float-time tstart)) - (t tstart))) - (tend (cond ((stringp tend) (org-time-string-to-seconds tend)) - ((consp tend) (float-time tend)) - (t tend))) - (t1 0) - time) - (remove-text-properties (point-min) (point-max) - `(,(or propname :org-clock-minutes) t - :org-clock-force-headline-inclusion t)) - (save-excursion - (goto-char (point-max)) - (while (re-search-backward re nil t) - (cond - ((match-end 2) - ;; Two time stamps. - (let* ((ts (float-time - (encode-time - (save-match-data - (org-parse-time-string (match-string 2)))))) - (te (float-time - (encode-time - (org-parse-time-string (match-string 3))))) - (dt (- (if tend (min te tend) te) - (if tstart (max ts tstart) ts)))) - (when (> dt 0) (cl-incf t1 (floor dt 60))))) - ((match-end 4) - ;; A naked time. - (setq t1 (+ t1 (string-to-number (match-string 5)) - (* 60 (string-to-number (match-string 4)))))) - (t ;A headline - ;; Add the currently clocking item time to the total. - (when (and org-clock-report-include-clocking-task - (eq (org-clocking-buffer) (current-buffer)) - (eq (marker-position org-clock-hd-marker) (point)) - tstart - tend - (>= (float-time org-clock-start-time) tstart) - (<= (float-time org-clock-start-time) tend)) - (let ((time (floor (time-convert - (time-since org-clock-start-time) - 'integer) - 60))) - (setq t1 (+ t1 time)))) - (let* ((headline-forced - (get-text-property (point) - :org-clock-force-headline-inclusion)) - (headline-included - (or (null headline-filter) - (save-excursion - (save-match-data (funcall headline-filter)))))) - (setq level (- (match-end 1) (match-beginning 1))) - (when (>= level lmax) - (setq ltimes (vconcat ltimes (make-vector lmax 0)) lmax (* 2 lmax))) - (when (or (> t1 0) (> (aref ltimes level) 0)) - (when (or headline-included headline-forced) - (if headline-included - (cl-loop for l from 0 to level do - (aset ltimes l (+ (aref ltimes l) t1)))) - (setq time (aref ltimes level)) - (goto-char (match-beginning 0)) - (put-text-property (point) (point-at-eol) - (or propname :org-clock-minutes) time) - (when headline-filter - (save-excursion - (save-match-data - (while (org-up-heading-safe) - (put-text-property - (point) (line-end-position) - :org-clock-force-headline-inclusion t)))))) - (setq t1 0) - (cl-loop for l from level to (1- lmax) do - (aset ltimes l 0))))))) - (setq org-clock-file-total-minutes (aref ltimes 0)))))) + (with-silent-modifications + (let* ((re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*" + org-clock-string + "[ \t]*\\(?:\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)\\|=>[ \t]+\\([0-9]+\\):\\([0-9]+\\)\\)")) + (lmax 30) + (ltimes (make-vector lmax 0)) + (level 0) + (tstart (cond ((stringp tstart) (org-time-string-to-seconds tstart)) + ((consp tstart) (float-time tstart)) + (t tstart))) + (tend (cond ((stringp tend) (org-time-string-to-seconds tend)) + ((consp tend) (float-time tend)) + (t tend))) + (t1 0) + time) + (remove-text-properties (point-min) (point-max) + `(,(or propname :org-clock-minutes) t + :org-clock-force-headline-inclusion t)) + (save-excursion + (goto-char (point-max)) + (while (re-search-backward re nil t) + (cond + ((match-end 2) + ;; Two time stamps. + (let* ((ts (float-time + (apply #'encode-time + (save-match-data + (org-parse-time-string (match-string 2)))))) + (te (float-time + (apply #'encode-time + (org-parse-time-string (match-string 3))))) + (dt (- (if tend (min te tend) te) + (if tstart (max ts tstart) ts)))) + (when (> dt 0) (cl-incf t1 (floor dt 60))))) + ((match-end 4) + ;; A naked time. + (setq t1 (+ t1 (string-to-number (match-string 5)) + (* 60 (string-to-number (match-string 4)))))) + (t ;A headline + ;; Add the currently clocking item time to the total. + (when (and org-clock-report-include-clocking-task + (eq (org-clocking-buffer) (current-buffer)) + (eq (marker-position org-clock-hd-marker) (point)) + tstart + tend + (>= (float-time org-clock-start-time) tstart) + (<= (float-time org-clock-start-time) tend)) + (let ((time (floor (org-time-convert-to-integer + (org-time-since org-clock-start-time)) + 60))) + (setq t1 (+ t1 time)))) + (let* ((headline-forced + (get-text-property (point) + :org-clock-force-headline-inclusion)) + (headline-included + (or (null headline-filter) + (save-excursion + (save-match-data (funcall headline-filter)))))) + (setq level (- (match-end 1) (match-beginning 1))) + (when (>= level lmax) + (setq ltimes (vconcat ltimes (make-vector lmax 0)) lmax (* 2 lmax))) + (when (or (> t1 0) (> (aref ltimes level) 0)) + (when (or headline-included headline-forced) + (if headline-included + (cl-loop for l from 0 to level do + (aset ltimes l (+ (aref ltimes l) t1)))) + (setq time (aref ltimes level)) + (goto-char (match-beginning 0)) + (put-text-property (point) (point-at-eol) + (or propname :org-clock-minutes) time) + (when headline-filter + (save-excursion + (save-match-data + (while (org-up-heading-safe) + (put-text-property + (point) (line-end-position) + :org-clock-force-headline-inclusion t)))))) + (setq t1 0) + (cl-loop for l from level to (1- lmax) do + (aset ltimes l 0))))))) + (setq org-clock-file-total-minutes (aref ltimes 0)))))) (defun org-clock-sum-current-item (&optional tstart) "Return time, clocked on current item in total." @@ -1939,29 +1956,28 @@ Use `\\[org-clock-remove-overlays]' to remove the subtree times." (defvar-local org-clock-overlays nil) (defun org-clock-put-overlay (time) - "Put an overlays on the current line, displaying TIME. -This creates a new overlay and stores it in `org-clock-overlays', so that it -will be easy to remove." - (let (ov tx) - (beginning-of-line) - (let ((case-fold-search nil)) - (when (looking-at org-complex-heading-regexp) - (goto-char (match-beginning 4)))) - (setq ov (make-overlay (point) (point-at-eol)) - tx (concat (buffer-substring-no-properties (point) (match-end 4)) - (org-add-props - (make-string - (max 0 (- (- 60 (current-column)) - (- (match-end 4) (match-beginning 4)) - (length (org-get-at-bol 'line-prefix)))) - ?\·) - '(face shadow)) - (org-add-props - (format " %9s " (org-duration-from-minutes time)) - '(face org-clock-overlay)) - "")) - (overlay-put ov 'display tx) - (push ov org-clock-overlays))) + "Put an overlay on the headline at point, displaying TIME. +Create a new overlay and store it in `org-clock-overlays', so +that it will be easy to remove. This function assumes point is +on a headline." + (org-match-line org-complex-heading-regexp) + (goto-char (match-beginning 4)) + (let* ((headline (match-string 4)) + (text (concat headline + (org-add-props + (make-string + (max (- (- 60 (current-column)) + (org-string-width headline) + (length (org-get-at-bol 'line-prefix))) + 0) + ?\·) + '(face shadow)) + (org-add-props + (format " %9s " (org-duration-from-minutes time)) + '(face org-clock-overlay)))) + (o (make-overlay (point) (line-end-position)))) + (org-overlay-display o text) + (push o org-clock-overlays))) ;;;###autoload (defun org-clock-remove-overlays (&optional _beg _end noremove) @@ -1976,7 +1992,7 @@ If NOREMOVE is nil, remove this function from the (remove-hook 'before-change-functions 'org-clock-remove-overlays 'local)))) -(defvar org-state) ;; dynamically scoped into this function +;;;###autoload (defun org-clock-out-if-current () "Clock out if the current entry contains the running clock. This is used to stop the clock after a TODO entry is marked DONE, @@ -1993,16 +2009,13 @@ and is only done if the variable `org-clock-out-when-done' is not nil." (or (buffer-base-buffer (current-buffer)) (current-buffer))) (< (point) org-clock-marker) - (> (save-excursion (outline-next-heading) (point)) + (> (org-with-wide-buffer (org-entry-end-position)) org-clock-marker)) ;; Clock out, but don't accept a logging message for this. (let ((org-log-note-clock-out nil) (org-clock-out-switch-to-state nil)) (org-clock-out)))) -(add-hook 'org-after-todo-state-change-hook - 'org-clock-out-if-current) - ;;;###autoload (defun org-clock-get-clocktable (&rest props) "Get a formatted clocktable with parameters according to PROPS. @@ -2054,6 +2067,8 @@ in the buffer and update it." (start (goto-char start))) (org-update-dblock)) +(org-dynamic-block-define "clocktable" #'org-clock-report) + (defun org-day-of-week (day month year) "Return the day of the week as an integer." (nth 6 @@ -2125,9 +2140,10 @@ time. The return value is a list containing two internal times, one for the beginning of the range and one for its end, like the ones -returned by `current time' or `encode-time' and a string used to +returned by `current-time' or `encode-time' and a string used to display information. If AS-STRINGS is non-nil, the returned -times will be formatted strings. +times will be formatted strings. Note that the first element is +always nil when KEY is `untilnow'. If WSTART is non-nil, use this number to specify the starting day of a week (monday is 1). If MSTART is non-nil, use this number @@ -2201,13 +2217,17 @@ have priority." (`lastq (setq key 'quarter shift -1)))) ;; Prepare start and end times depending on KEY's type. (pcase key - ((or `day `today) (setq m 0 h 0 h1 24 d (+ d shift))) + ((or `day `today) (setq m 0 + h org-extend-today-until + h1 (+ 24 org-extend-today-until) + d (+ d shift))) ((or `week `thisweek) (let* ((ws (or wstart 1)) (diff (+ (* -7 shift) (if (= dow 0) (- 7 ws) (- dow ws))))) - (setq m 0 h 0 d (- d diff) d1 (+ 7 d)))) + (setq m 0 h org-extend-today-until d (- d diff) d1 (+ 7 d)))) ((or `month `thismonth) - (setq h 0 m 0 d (or mstart 1) month (+ month shift) month1 (1+ month))) + (setq h org-extend-today-until m 0 d (or mstart 1) + month (+ month shift) month1 (1+ month))) ((or `quarter `thisq) ;; Compute if this shift remains in this year. If not, compute ;; how many years and quarters we have to shift (via floor*) and @@ -2225,32 +2245,22 @@ have priority." (setq shiftedy (- y (+ 1 (nth 0 tmp))) shiftedm (- 13 (* 3 (nth 1 tmp))) shiftedq (- 5 (nth 1 tmp))))) - (setq m 0 h 0 d 1 month shiftedm month1 (+ 3 shiftedm) y shiftedy)) + (setq m 0 h org-extend-today-until d 1 + month shiftedm month1 (+ 3 shiftedm) y shiftedy)) ((> (+ q shift) 0) ; Shift is within this year. (setq shiftedq (+ q shift)) (setq shiftedy y) (let ((qshift (* 3 (1- (+ q shift))))) - (setq m 0 h 0 d 1 month (+ 1 qshift) month1 (+ 4 qshift)))))) + (setq m 0 h org-extend-today-until d 1 + month (+ 1 qshift) month1 (+ 4 qshift)))))) ((or `year `thisyear) - (setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y))) + (setq m 0 h org-extend-today-until d 1 month 1 y (+ y shift) y1 (1+ y))) ((or `interactive `untilnow)) ; Special cases, ignore them. (_ (user-error "No such time block %s" key))) ;; Format start and end times according to AS-STRINGS. (let* ((start (pcase key (`interactive (org-read-date nil t nil "Range start? ")) - ;; In theory, all clocks started after the dawn of - ;; humanity. However, the platform's clock - ;; support might not go back that far. Choose the - ;; POSIX timestamp -2**41 (approximately 68,000 - ;; BCE) if that works, otherwise -2**31 (1901) if - ;; that works, otherwise 0 (1970). Going back - ;; billions of years would loop forever on Mac OS - ;; X 10.6 with Emacs 26 and earlier (Bug#27736). - (`untilnow - (let ((old 0)) - (dolist (older '((-32768 0) (-33554432 0)) old) - (when (ignore-errors (decode-time older)) - (setq old older))))) + (`untilnow nil) (_ (encode-time 0 m h d month y)))) (end (pcase key (`interactive (org-read-date nil t nil "Range end? ")) @@ -2274,7 +2284,7 @@ have priority." (`untilnow "now")))) (if (not as-strings) (list start end text) (let ((f (cdr org-time-stamp-formats))) - (list (format-time-string f start) + (list (and start (format-time-string f start)) (format-time-string f end) text)))))) @@ -2382,15 +2392,22 @@ the currently selected interval size." (`file-with-archives (and buffer-file-name (org-add-archive-files (list buffer-file-name)))) + ((or `nil `file `subtree `tree + (and (pred symbolp) + (guard (string-match "\\`tree\\([0-9]+\\)\\'" + (symbol-name scope))))) + (or (buffer-file-name (buffer-base-buffer)) + (current-buffer))) ((pred functionp) (funcall scope)) ((pred consp) scope) - (_ (or (buffer-file-name) (current-buffer))))) + (_ (user-error "Unknown scope: %S" scope)))) (block (plist-get params :block)) (ts (plist-get params :tstart)) (te (plist-get params :tend)) (ws (plist-get params :wstart)) (ms (plist-get params :mstart)) (step (plist-get params :step)) + (hide-files (plist-get params :hidefiles)) (formatter (or (plist-get params :formatter) org-clock-clocktable-formatter 'org-clocktable-write-default)) @@ -2445,7 +2462,9 @@ the currently selected interval size." ;; Even though `file-with-archives' can consist of ;; multiple files, we consider this is one extended file ;; instead. - (and (consp files) (not (eq scope 'file-with-archives))))) + (and (not hide-files) + (consp files) + (not (eq scope 'file-with-archives))))) (funcall formatter origin @@ -2475,6 +2494,7 @@ from the dynamic block definition." (narrow (or (plist-get params :narrow) (and compact? '40!))) (level? (and (not compact?) (plist-get params :level))) (timestamp (plist-get params :timestamp)) + (tags (plist-get params :tags)) (properties (plist-get params :properties)) (time-columns (if (or compact? (< maxlevel 2)) 1 @@ -2535,6 +2555,7 @@ from the dynamic block definition." (if multifile "|" "") ;file column, maybe (if level? "|" "") ;level column, maybe (if timestamp "|" "") ;timestamp column, maybe + (if tags "|" "") ;tags columns, maybe (if properties ;properties columns, maybe (make-string (length properties) ?|) "") @@ -2552,6 +2573,8 @@ from the dynamic block definition." (if timestamp ;timestamp column, maybe (concat (org-clock--translate "Timestamp" lang) "|") "") + (if tags "Tags |" "") ;tags columns, maybe + (if properties ;properties columns, maybe (concat (mapconcat #'identity properties "|") "|") "") @@ -2566,8 +2589,9 @@ from the dynamic block definition." "|" ;table line starter (if multifile (format "| %s " (org-clock--translate "ALL" lang)) "") ;file column, maybe - (if level? "|" "") ;level column, maybe + (if level? "|" "") ;level column, maybe (if timestamp "|" "") ;timestamp column, maybe + (if tags "|" "") ;timestamp column, maybe (make-string (length properties) ?|) ;properties columns, maybe (concat (format org-clock-total-time-cell-format (org-clock--translate "Total time" lang)) @@ -2592,13 +2616,14 @@ from the dynamic block definition." (when multifile ;; Summarize the time collected from this file. (insert-before-markers - (format (concat "| %s %s | %s%s" + (format (concat "| %s %s | %s%s%s" (format org-clock-file-time-cell-format (org-clock--translate "File time" lang)) " | *%s*|\n") (file-name-nondirectory file-name) - (if level? "| " "") ;level column, maybe + (if level? "| " "") ;level column, maybe (if timestamp "| " "") ;timestamp column, maybe + (if tags "| " "") ;tags column, maybe (if properties ;properties columns, maybe (make-string (length properties) ?|) "") @@ -2606,16 +2631,16 @@ from the dynamic block definition." ;; Get the list of node entries and iterate over it (when (> maxlevel 0) - (pcase-dolist (`(,level ,headline ,ts ,time ,props) entries) + (pcase-dolist (`(,level ,headline ,tgs ,ts ,time ,props) entries) (when narrow-cut-p (setq headline (if (and (string-match - (format "\\`%s\\'" org-bracket-link-regexp) + (format "\\`%s\\'" org-link-bracket-re) headline) - (match-end 3)) + (match-end 2)) (format "[[%s][%s]]" (match-string 1 headline) - (org-shorten-string (match-string 3 headline) + (org-shorten-string (match-string 2 headline) narrow)) (org-shorten-string headline narrow)))) (cl-flet ((format-field (f) (format (cond ((not emph) "%s |") @@ -2628,6 +2653,7 @@ from the dynamic block definition." (if multifile "|" "") ;free space for file name column? (if level? (format "%d|" level) "") ;level, maybe (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 @@ -2683,69 +2709,87 @@ LEVEL is an integer. Indent by two spaces per level above 1." (concat "\\_" (make-string (* 2 (1- level)) ?\s)))) (defun org-clocktable-steps (params) - "Step through the range to make a number of clock tables." - (let* ((ts (plist-get params :tstart)) - (te (plist-get params :tend)) - (ws (plist-get params :wstart)) - (ms (plist-get params :mstart)) - (step0 (plist-get params :step)) - (step (cdr (assq step0 '((day . 86400) (week . 604800))))) - (stepskip0 (plist-get params :stepskip0)) - (block (plist-get params :block)) - cc tsb) - (when block - (setq cc (org-clock-special-range block nil t ws ms) - ts (car cc) - te (nth 1 cc))) - (cond - ((numberp ts) - ;; If ts is a number, it's an absolute day number from - ;; org-agenda. - (pcase-let ((`(,month ,day ,year) (calendar-gregorian-from-absolute ts))) - (setq ts (float-time (encode-time 0 0 0 day month year))))) - (ts - (setq ts (float-time (org-time-string-to-time ts))))) - (cond - ((numberp te) - ;; Likewise for te. - (pcase-let ((`(,month ,day ,year) (calendar-gregorian-from-absolute te))) - (setq te (float-time (encode-time 0 0 0 day month year))))) - (te - (setq te (float-time (org-time-string-to-time te))))) - (setq tsb - (if (eq step0 'week) - (let ((dow (nth 6 (decode-time ts)))) - (if (<= dow ws) ts - (- ts (* 86400 (- dow ws))))) - ts)) - (while (< tsb te) + "Create one or more clock tables, according to PARAMS. +Step through the range specifications in plist PARAMS to make +a number of clock tables." + (let* ((ignore-empty-tables (plist-get params :stepskip0)) + (step (plist-get params :step)) + (step-header + (pcase step + (`day "Daily report: ") + (`week "Weekly report starting on: ") + (`month "Monthly report starting on: ") + (`year "Annual report starting on: ") + (_ (user-error "Unknown `:step' specification: %S" step)))) + (week-start (or (plist-get params :wstart) 1)) + (month-start (or (plist-get params :mstart) 1)) + (range + (pcase (plist-get params :block) + (`nil nil) + (range + (org-clock-special-range range nil t week-start month-start)))) + ;; For both START and END, any number is an absolute day + ;; number from Agenda. Otherwise, consider value to be an Org + ;; timestamp string. The `:block' property has precedence + ;; over `:tstart' and `:tend'. + (start + (pcase (if range (car range) (plist-get params :tstart)) + ((and (pred numberp) n) + (pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n))) + (apply #'encode-time (list 0 0 org-extend-today-until d m y)))) + (timestamp + (seconds-to-time + (org-matcher-time (or timestamp + ;; The year Org was born. + "<2003-01-01 Thu 00:00>")))))) + (end + (pcase (if range (nth 1 range) (plist-get params :tend)) + ((and (pred numberp) n) + (pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n))) + (apply #'encode-time (list 0 0 org-extend-today-until d m y)))) + (timestamp (seconds-to-time (org-matcher-time timestamp)))))) + (while (time-less-p start end) (unless (bolp) (insert "\n")) - (let ((start-time (max tsb ts))) - (cl-incf tsb (let ((dow (nth 6 (decode-time tsb)))) - (if (or (eq step0 'day) - (= dow ws)) - step - (* 86400 (- ws dow))))) - (insert "\n" - (if (eq step0 'day) "Daily report: " - "Weekly report starting on: ") - (format-time-string (org-time-stamp-format nil t) start-time) - "\n") - (let ((table-begin (line-beginning-position 0)) - (step-time - (org-dblock-write:clocktable - (org-combine-plists - params - (list - :header "" :step nil :block nil - :tstart (format-time-string (org-time-stamp-format t t) - start-time) - :tend (format-time-string (org-time-stamp-format t t) - (min te tsb))))))) - (re-search-forward "^[ \t]*#\\+END:") - (when (and stepskip0 (equal step-time 0)) - ;; Remove the empty table - (delete-region (line-beginning-position) table-begin)))) + ;; Insert header before each clock table. + (insert "\n" + step-header + (format-time-string (org-time-stamp-format nil t) start) + "\n") + ;; Compute NEXT, which is the end of the current clock table, + ;; according to step. + (let* ((next + (apply #'encode-time + (pcase-let + ((`(,_ ,_ ,_ ,d ,m ,y ,dow . ,_) (decode-time start))) + (pcase step + (`day (list 0 0 org-extend-today-until (1+ d) m y)) + (`week + (let ((offset (if (= dow week-start) 7 + (mod (- week-start dow) 7)))) + (list 0 0 org-extend-today-until (+ d offset) m y))) + (`month (list 0 0 0 month-start (1+ m) y)) + (`year (list 0 0 org-extend-today-until 1 1 (1+ y))))))) + (table-begin (line-beginning-position 0)) + (step-time + ;; Write clock table between START and NEXT. + (org-dblock-write:clocktable + (org-combine-plists + params (list :header "" + :step nil + :block nil + :tstart (format-time-string + (org-time-stamp-format t t) + start) + :tend (format-time-string + (org-time-stamp-format t t) + ;; Never include clocks past END. + (if (time-less-p end next) end next))))))) + (let ((case-fold-search t)) (re-search-forward "^[ \t]*#\\+END:")) + ;; Remove the table if it is empty and `:stepskip0' is + ;; non-nil. + (when (and ignore-empty-tables (equal step-time 0)) + (delete-region (line-beginning-position) table-begin)) + (setq start next)) (end-of-line 0)))) (defun org-clock-get-table-data (file params) @@ -2758,13 +2802,14 @@ file time (in minutes) as 1st and 2nd elements. The third element of this list will be a list of headline entries. Each entry has the following structure: - (LEVEL HEADLINE TIMESTAMP TIME PROPERTIES) + (LEVEL HEADLINE TAGS TIMESTAMP TIME PROPERTIES) LEVEL: The level of the headline, as an integer. This will be the reduced level, so 1,2,3,... even if only odd levels are being used. HEADLINE: The text of the headline. Depending on PARAMS, this may already be formatted like a link. +TAGS: The list of tags of the headline. TIMESTAMP: If PARAMS require it, this will be a time stamp found in the entry, any of SCHEDULED, DEADLINE, NORMAL, or first inactive, in this sequence. @@ -2783,9 +2828,10 @@ PROPERTIES: The list properties specified in the `:properties' parameter (block (plist-get params :block)) (link (plist-get params :link)) (tags (plist-get params :tags)) + (match (plist-get params :match)) (properties (plist-get params :properties)) (inherit-property-p (plist-get params :inherit-props)) - (matcher (and tags (cdr (org-make-tags-matcher tags)))) + (matcher (and match (cdr (org-make-tags-matcher match)))) cc st p tbl) (setq org-clock-file-total-minutes nil) @@ -2806,10 +2852,11 @@ PROPERTIES: The list properties specified in the `:properties' parameter (org-clock-sum ts te (when matcher `(lambda () - (let* ((tags-list (org-get-tags-at)) + (let* ((todo (org-get-todo-state)) + (tags-list (org-get-tags)) (org-scanner-tags tags-list) (org-trust-scanner-tags t)) - (funcall ,matcher nil tags-list nil))))) + (funcall ,matcher todo tags-list nil))))) (goto-char (point-min)) (setq st t) (while (or (and (bobp) (prog1 st (setq st nil)) @@ -2826,8 +2873,8 @@ PROPERTIES: The list properties specified in the `:properties' parameter (hdl (if (not link) headline (let ((search - (org-make-org-heading-search-string headline))) - (org-make-link-string + (org-link-heading-search-string headline))) + (org-link-make-string (if (not (buffer-file-name)) search (format "file:%s::%s" (buffer-file-name) search)) ;; Prune statistics cookies. Replace @@ -2838,6 +2885,7 @@ PROPERTIES: The list properties specified in the `:properties' parameter (replace-regexp-in-string "\\[[0-9]+%\\]\\|\\[[0-9]+/[0-9]+\\]" "" headline))))))) + (tgs (and tags (org-get-tags))) (tsp (and timestamp (cl-some (lambda (p) (org-entry-get (point) p)) @@ -2852,7 +2900,7 @@ PROPERTIES: The list properties specified in the `:properties' parameter (point) p inherit-property-p))) (and v (cons p v)))) properties))))) - (push (list level hdl tsp time props) tbl))))))) + (push (list level hdl tgs tsp time props) tbl))))))) (list file org-clock-file-total-minutes (nreverse tbl))))) ;; Saving and loading the clock @@ -2889,9 +2937,10 @@ Otherwise, return nil." (end-of-line 1) (setq ts (match-string 1) te (match-string 3)) - (setq s (float-time - (time-subtract (org-time-string-to-time te) - (org-time-string-to-time ts))) + (setq s (- (float-time + (apply #'encode-time (org-parse-time-string te))) + (float-time + (apply #'encode-time (org-parse-time-string ts)))) neg (< s 0) s (abs s) h (floor (/ s 3600)) diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el index 51a8eff33d7..caef4251443 100644 --- a/lisp/org/org-colview.el +++ b/lisp/org/org-colview.el @@ -41,6 +41,9 @@ (declare-function org-element-property "org-element" (property element)) (declare-function org-element-restriction "org-element" (element)) (declare-function org-element-type "org-element" (element)) +(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)) (defvar org-agenda-columns-add-appointments-to-effort-sum) (defvar org-agenda-columns-compute-summary-properties) @@ -67,7 +70,8 @@ or nil if the normal value should be used." (defcustom org-columns-summary-types nil "Alist between operators and summarize functions. -Each association follows the pattern (LABEL . SUMMARIZE) where +Each association follows the pattern (LABEL . SUMMARIZE), +or (LABEL SUMMARIZE COLLECT) where LABEL is a string used in #+COLUMNS definition describing the summary type. It can contain any character but \"}\". It is @@ -78,6 +82,13 @@ Each association follows the pattern (LABEL . SUMMARIZE) where The second one is a format string or nil. It has to return a string summarizing the list of values. + COLLECT is a function called with one argument, a property + name. It is called in the context of a headline and must + return the collected property, or the empty string. You can + use this to only collect a property if a related conditional + properties is set, e.g., to return VACATION_DAYS only if + CONFIRMED is true. + Note that the return value can become one value for an higher order summary, so the function is expected to handle its own output. @@ -88,7 +99,11 @@ in `org-columns-summary-types-default', which see." :version "26.1" :package-version '(Org . "9.0") :type '(alist :key-type (string :tag " Label") - :value-type (function :tag "Summarize"))) + :value-type + (choice (function :tag "Summarize") + (list :tag "Collect and summarize" + (function :tag "Summarize") + (function :tag "Collect"))))) @@ -221,21 +236,27 @@ See `org-columns-summary-types' for details.") "--" ["Quit" org-columns-quit t])) -(defun org-columns--displayed-value (spec value) +(defun org-columns--displayed-value (spec value &optional no-star) "Return displayed value for specification SPEC in current entry. + SPEC is a column format specification as stored in `org-columns-current-fmt-compiled'. VALUE is the real value to -display, as a string." +display, as a string. + +When NO-STAR is non-nil, do not add asterisks before displayed +value for ITEM property." (or (and (functionp org-columns-modify-value-for-display-function) (funcall org-columns-modify-value-for-display-function (nth 1 spec) ;column name value)) (pcase spec (`("ITEM" . ,_) - (concat (make-string (1- (org-current-level)) - (if org-hide-leading-stars ?\s ?*)) - "* " - (org-columns-compact-links value))) + (let ((stars + (and (not no-star) + (concat (make-string (1- (org-current-level)) + (if org-hide-leading-stars ?\s ?*)) + "* ")))) + (concat stars (org-link-display-format value)))) (`(,_ ,_ ,_ ,_ nil) value) ;; If PRINTF is set, assume we are displaying a number and ;; obey to the format string. @@ -268,7 +289,11 @@ possible to override it with optional argument COMPILED-FMT." (get-text-property (point) 'duration)) 'face 'org-warning)) ""))) - (list spec v (org-columns--displayed-value spec v)))))) + ;; A non-nil COMPILED-FMT means we're calling from Org + ;; Agenda mode, where we do not want leading stars for + ;; ITEM. Hence the optional argument for + ;; `org-columns--displayed-value'. + (list spec v (org-columns--displayed-value spec v compiled-fmt)))))) (or compiled-fmt org-columns-current-fmt-compiled)))) (defun org-columns--set-widths (cache) @@ -301,13 +326,29 @@ integers greater than 0." (defun org-columns--summarize (operator) "Return summary function associated to string OPERATOR." - (if (not operator) nil - (cdr (or (assoc operator org-columns-summary-types) - (assoc operator org-columns-summary-types-default) - (error "Unknown %S operator" operator))))) + (pcase (or (assoc operator org-columns-summary-types) + (assoc operator org-columns-summary-types-default)) + (`nil (error "Unknown %S operator" operator)) + (`(,_ . ,(and (pred functionp) summarize)) summarize) + (`(,_ ,summarize ,_) summarize) + (_ (error "Invalid definition for operator %S" operator)))) + +(defun org-columns--collect (operator) + "Return collect function associated to string OPERATOR. +Return nil if no collect function is associated to OPERATOR." + (pcase (or (assoc operator org-columns-summary-types) + (assoc operator org-columns-summary-types-default)) + (`nil (error "Unknown %S operator" operator)) + (`(,_ . ,(pred functionp)) nil) ;default value + (`(,_ ,_ ,collect) collect) + (_ (error "Invalid definition for operator %S" operator)))) (defun org-columns--overlay-text (value fmt width property original) - "Return text." + "Return decorated VALUE string for columns overlay display. +FMT is a format string. WIDTH is the width of the column, as an +integer. PROPERTY is the property being displayed, as a string. +ORIGINAL is the real string, i.e., before it is modified by +`org-columns--displayed-value'." (format fmt (let ((v (org-columns-add-ellipses value width))) (pcase property @@ -387,14 +428,14 @@ DATELINE is non-nil when the face used should be (line-beginning-position 2)))) (overlay-put ov 'keymap org-columns-map) (push ov org-columns-overlays)) - (org-with-silent-modifications - (let ((inhibit-read-only t)) - (put-text-property - (line-end-position 0) - (line-beginning-position 2) - 'read-only - (substitute-command-keys - "Type \\<org-columns-map>`\\[org-columns-edit-value]' \ + (with-silent-modifications + (let ((inhibit-read-only t)) + (put-text-property + (line-end-position 0) + (line-beginning-position 2) + 'read-only + (substitute-command-keys + "Type \\<org-columns-map>`\\[org-columns-edit-value]' \ to edit property"))))))) (defun org-columns-add-ellipses (string width) @@ -424,6 +465,7 @@ for the duration of the command.") "Overlay the newline before the current line with the table title." (interactive) (let ((title "") + (linum-offset (org-line-number-display-width 'columns)) (i 0)) (dolist (column org-columns-current-fmt-compiled) (pcase column @@ -435,7 +477,7 @@ for the duration of the command.") (setq-local org-previous-header-line-format header-line-format) (setq org-columns-full-header-line-format (concat - (org-add-props " " nil 'display '(space :align-to 0)) + (org-add-props " " nil 'display `(space :align-to ,linum-offset)) (org-add-props (substring title 0 -1) nil 'face 'org-column-title))) (setq org-columns-previous-hscroll -1) (add-hook 'post-command-hook 'org-columns-hscroll-title nil 'local))) @@ -443,13 +485,15 @@ for the duration of the command.") (defun org-columns-hscroll-title () "Set the `header-line-format' so that it scrolls along with the table." (sit-for .0001) ; need to force a redisplay to update window-hscroll - (when (not (= (window-hscroll) org-columns-previous-hscroll)) - (setq header-line-format - (concat (substring org-columns-full-header-line-format 0 1) - (substring org-columns-full-header-line-format - (1+ (window-hscroll)))) - org-columns-previous-hscroll (window-hscroll)) - (force-mode-line-update))) + (let ((hscroll (window-hscroll))) + (when (/= org-columns-previous-hscroll hscroll) + (setq header-line-format + (concat (substring org-columns-full-header-line-format 0 1) + (substring org-columns-full-header-line-format + (min (length org-columns-full-header-line-format) + (1+ hscroll)))) + org-columns-previous-hscroll hscroll) + (force-mode-line-update)))) (defvar org-colview-initial-truncate-line-value nil "Remember the value of `truncate-lines' across colview.") @@ -466,24 +510,16 @@ for the duration of the command.") (set-marker org-columns-begin-marker nil) (when (markerp org-columns-top-level-marker) (set-marker org-columns-top-level-marker nil)) - (org-with-silent-modifications - (mapc #'delete-overlay org-columns-overlays) - (setq org-columns-overlays nil) - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(read-only t)))) + (with-silent-modifications + (mapc #'delete-overlay org-columns-overlays) + (setq org-columns-overlays nil) + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(read-only t)))) (when org-columns-flyspell-was-active (flyspell-mode 1)) (when (local-variable-p 'org-colview-initial-truncate-line-value) (setq truncate-lines org-colview-initial-truncate-line-value)))) -(defun org-columns-compact-links (s) - "Replace [[link][desc]] with [desc] or [link]." - (while (string-match org-bracket-link-regexp s) - (setq s (replace-match - (concat "[" (match-string (if (match-end 3) 3 1) s) "]") - t t s))) - s) - (defun org-columns-show-value () "Show the full value of the property." (interactive) @@ -495,10 +531,10 @@ for the duration of the command.") (defun org-columns-quit () "Remove the column overlays and in this way exit column editing." (interactive) - (org-with-silent-modifications - (org-columns-remove-overlays) - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(read-only t)))) + (with-silent-modifications + (org-columns-remove-overlays) + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(read-only t)))) (if (not (eq major-mode 'org-agenda-mode)) (setq org-columns-current-fmt nil) (setq org-agenda-columns-active nil) @@ -526,9 +562,17 @@ for the duration of the command.") (org-columns-next-allowed-value) (org-columns-edit-value "TAGS"))) -(defvar org-agenda-overriding-columns-format nil +(defvar org-overriding-columns-format nil + "When set, overrides any other format definition for the agenda. +Don't set this, this is meant for dynamic scoping. Set +`org-columns-default-format' and `org-columns-default-format-for-agenda' +instead. You should use this variable only in the local settings +section for a custom agenda view.") + +(defvar-local org-local-columns-format nil "When set, overrides any other format definition for the agenda. -Don't set this, this is meant for dynamic scoping.") +This can be set as a buffer local value to avoid interfering with +dynamic scoping for `org-overriding-columns-format'.") (defun org-columns-edit-value (&optional key) "Edit the value of the property at point in column view. @@ -544,7 +588,7 @@ Where possible, use the standard interface for changing this line." (action (pcase key ("CLOCKSUM" - (error "This special column cannot be edited")) + (user-error "This special column cannot be edited")) ("ITEM" (lambda () (org-with-point-at pom (org-edit-headline)))) ("TODO" @@ -561,7 +605,7 @@ Where possible, use the standard interface for changing this line." (if (eq org-fast-tag-selection-single-key 'expert) t org-fast-tag-selection-single-key))) - (call-interactively #'org-set-tags))))) + (call-interactively #'org-set-tags-command))))) ("DEADLINE" (lambda () (org-with-point-at pom (call-interactively #'org-deadline)))) @@ -589,7 +633,7 @@ Where possible, use the standard interface for changing this line." (org-columns--call action) ;; The following let preserves the current format, and makes ;; sure that in only a single file things need to be updated. - (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) + (let* ((org-overriding-columns-format org-columns-current-fmt) (buffer (marker-buffer pom)) (org-agenda-contributing-files (list (with-current-buffer buffer @@ -597,8 +641,8 @@ Where possible, use the standard interface for changing this line." (org-agenda-columns))) (t (let ((inhibit-read-only t)) - (org-with-silent-modifications - (remove-text-properties (max (point-min) (1- bol)) eol '(read-only t))) + (with-silent-modifications + (remove-text-properties (max (point-min) (1- bol)) eol '(read-only t))) (org-columns--call action)) ;; Some properties can modify headline (e.g., "TODO"), and ;; possible shuffle overlays. Make sure they are still all at @@ -683,7 +727,7 @@ an integer, select that value." (org-columns--call action) ;; The following let preserves the current format, and makes ;; sure that in only a single file things need to be updated. - (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) + (let* ((org-overriding-columns-format org-columns-current-fmt) (buffer (marker-buffer pom)) (org-agenda-contributing-files (list (with-current-buffer buffer @@ -719,13 +763,13 @@ around it." (setq time-after (copy-sequence time)) (setf (nth 3 time-before) (1- (nth 3 time))) (setf (nth 3 time-after) (1+ (nth 3 time))) - (mapcar (lambda (x) (format-time-string fmt (encode-time x))) + (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x))) (list time-before time time-after))))) (defun org-columns-open-link (&optional arg) (interactive "P") (let ((value (get-char-property (point) 'org-columns-value))) - (org-open-link-from-string value arg))) + (org-link-open-from-string value arg))) ;;;###autoload (defun org-columns-get-format-and-top-level () @@ -783,17 +827,17 @@ 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) - (when global (goto-char (point-min))) - (if (markerp org-columns-begin-marker) - (move-marker org-columns-begin-marker (point)) - (setq org-columns-begin-marker (point-marker))) - (org-columns-goto-top-level) - ;; Initialize `org-columns-current-fmt' and - ;; `org-columns-current-fmt-compiled'. - (let ((org-columns--time (float-time))) - (org-columns-get-format columns-fmt-string) - (unless org-columns-inhibit-recalculation (org-columns-compute-all)) - (save-excursion + (save-excursion + (when global (goto-char (point-min))) + (if (markerp org-columns-begin-marker) + (move-marker org-columns-begin-marker (point)) + (setq org-columns-begin-marker (point-marker))) + (org-columns-goto-top-level) + ;; Initialize `org-columns-current-fmt' and + ;; `org-columns-current-fmt-compiled'. + (let ((org-columns--time (float-time))) + (org-columns-get-format columns-fmt-string) + (unless org-columns-inhibit-recalculation (org-columns-compute-all)) (save-restriction (when (and (not global) (org-at-heading-p)) (narrow-to-region (point) (org-end-of-subtree t t))) @@ -1011,8 +1055,8 @@ the current buffer." (defun org-columns-uncompile-format (compiled) "Turn the compiled columns format back into a string representation. -COMPILED is an alist, as returned by -`org-columns-compile-format', which see." + +COMPILED is an alist, as returned by `org-columns-compile-format'." (mapconcat (lambda (spec) (pcase spec @@ -1085,16 +1129,7 @@ as a canonical duration, i.e., using units defined in "Apply FUN to time values TIMES. Return the result as a duration." (org-duration-from-minutes - (apply fun - (mapcar (lambda (time) - ;; Unlike to `org-duration-to-minutes' standard - ;; behavior, we want to consider plain numbers as - ;; hours. As a consequence, we treat them - ;; differently. - (if (string-match-p "\\`[0-9]+\\(?:\\.[0-9]*\\)?\\'" time) - (* 60 (string-to-number time)) - (org-duration-to-minutes time))) - times)) + (apply fun (mapcar #'org-duration-to-minutes times)) (org-duration-h:mm-only-p times))) (defun org-columns--compute-spec (spec &optional update) @@ -1111,7 +1146,9 @@ properties drawers." (last-level lmax) (property (car spec)) (printf (nth 4 spec)) - (summarize (org-columns--summarize (nth 3 spec)))) + (operator (nth 3 spec)) + (collect (and operator (org-columns--collect operator))) + (summarize (and operator (org-columns--summarize operator)))) (org-with-wide-buffer ;; Find the region to compute. (goto-char org-columns-top-level-marker) @@ -1123,7 +1160,8 @@ properties drawers." (setq last-level level)) (setq level (org-reduced-level (org-outline-level))) (let* ((pos (match-beginning 0)) - (value (org-entry-get nil property)) + (value (if collect (funcall collect property) + (org-entry-get (point) property))) (value-set (org-string-nw-p value))) (cond ((< level last-level) @@ -1142,9 +1180,9 @@ properties drawers." (old (assoc spec summaries-alist))) (if old (setcdr old summary) (push (cons spec summary) summaries-alist) - (org-with-silent-modifications - (add-text-properties - pos (1+ pos) (list 'org-summaries summaries-alist))))) + (with-silent-modifications + (add-text-properties + pos (1+ pos) (list 'org-summaries summaries-alist))))) ;; When PROPERTY exists in current node, even if empty, ;; but its value doesn't match the one computed, use ;; the latter instead. @@ -1180,9 +1218,9 @@ column specification." (defun org-columns-compute-all () "Compute all columns that have operators defined." - (org-with-silent-modifications - (remove-text-properties (point-min) (point-max) '(org-summaries t))) - (let ((org-columns--time (float-time (current-time))) + (with-silent-modifications + (remove-text-properties (point-min) (point-max) '(org-summaries t))) + (let ((org-columns--time (float-time)) seen) (dolist (spec org-columns-current-fmt-compiled) (let ((property (car spec))) @@ -1212,7 +1250,7 @@ When PRINTF is non-nil, use it to format the result." "Summarize CHECK-BOXES with a check-box cookie." (format "[%d/%d]" (cl-count-if (lambda (b) (or (equal b "[X]") - (string-match-p "\\[\\([1-9]\\)/\\1\\]" b))) + (string-match-p "\\[\\([1-9]\\)/\\1\\]" b))) check-boxes) (length check-boxes))) @@ -1261,17 +1299,17 @@ When PRINTF is non-nil, use it to format the result." times)) (defun org-columns--summary-min-age (ages _) - "Compute the minimum time among AGES." + "Compute the minimum age among AGES." (org-columns--format-age (apply #'min (mapcar #'org-columns--age-to-minutes ages)))) (defun org-columns--summary-max-age (ages _) - "Compute the maximum time among AGES." + "Compute the maximum age among AGES." (org-columns--format-age (apply #'max (mapcar #'org-columns--age-to-minutes ages)))) (defun org-columns--summary-mean-age (ages _) - "Compute the minimum time among AGES." + "Compute the mean age among AGES." (org-columns--format-age (/ (apply #'+ (mapcar #'org-columns--age-to-minutes ages)) (float (length ages))))) @@ -1298,14 +1336,15 @@ and variances (respectively) of the individual estimates." ;;; Dynamic block for Column view -(defun org-columns--capture-view (maxlevel skip-empty format local) +(defun org-columns--capture-view (maxlevel match skip-empty exclude-tags format local) "Get the column view of the current buffer. MAXLEVEL sets the level limit. SKIP-EMPTY tells whether to skip empty rows, an empty row being one where all the column view -specifiers but ITEM are empty. FORMAT is a format string for -columns, or nil. When LOCAL is non-nil, only capture headings in -current subtree. +specifiers but ITEM are empty. EXCLUDE-TAGS is a list of tags +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 @@ -1328,12 +1367,17 @@ other rows. Each row is a list of fields, as strings, or 'org-columns-value 'org-columns-value-modified))) row))) - (unless (and skip-empty - (let ((r (delete-dups (remove "" row)))) - (or (null r) (and has-item (= (length r) 1))))) + (unless (or + (and skip-empty + (let ((r (delete-dups (remove "" row)))) + (or (null r) (and has-item (= (length r) 1))))) + (and exclude-tags + (cl-some (lambda (tag) (member tag exclude-tags)) + (org-get-tags)))) (push (cons (org-reduced-level (org-current-level)) (nreverse row)) table))))) - (and maxlevel (format "LEVEL<=%d" maxlevel)) + (or (and maxlevel (format "LEVEL<=%d" maxlevel)) + (and match match)) (and local 'tree) 'archive 'comment) (org-columns-quit) @@ -1357,24 +1401,54 @@ an inline src-block." ;;;###autoload (defun org-dblock-write:columnview (params) "Write the column view table. + PARAMS is a property list of parameters: -:id the :ID: property of the entry where the columns view - should be built. When the symbol `local', call locally. - When `global' call column view with the cursor at the beginning - of the buffer (usually this means that the whole buffer switches - to column view). When \"file:path/to/file.org\", invoke column - view at the start of that file. Otherwise, the ID is located - using `org-id-find'. -:hlines When t, insert a hline before each item. When a number, insert - a hline before each level <= that number. -:indent When non-nil, indent each ITEM field according to its level. -:vlines When t, make each column a colgroup to enforce vertical lines. -:maxlevel When set to a number, don't capture headlines below this level. -:skip-empty-rows - When t, skip rows where all specifiers other than ITEM are empty. -:width apply widths specified in columns format using <N> specifiers. -:format When non-nil, specify the column view format to use." +`:id' (mandatory) + + The ID property of the entry where the columns view should be + built. When the symbol `local', call locally. When `global' + call column view with the cursor at the beginning of the + buffer (usually this means that the whole buffer switches to + column view). When \"file:path/to/file.org\", invoke column + view at the start of that file. Otherwise, the ID is located + using `org-id-find'. + +`:exclude-tags' + + List of tags to exclude from column view table. + +`:format' + + When non-nil, specify the column view format to use. + +`:hlines' + + When non-nil, insert a hline before each item. When + a number, insert a hline before each level inferior or equal + to that number. + +`:indent' + + When non-nil, indent each ITEM field according to its level. + +`:match' + + When set to a string, use this as a tags/property match filter. + +`:maxlevel' + + When set to a number, don't capture headlines below this level. + +`:skip-empty-rows' + + When non-nil, skip rows where all specifiers other than ITEM + are empty. + +`:vlines' + + When non-nil, make each column a column group to enforce + vertical lines." (let ((table (let ((id (plist-get params :id)) view-file view-pos) @@ -1397,7 +1471,9 @@ PARAMS is a property list of parameters: (org-with-wide-buffer (when view-pos (goto-char view-pos)) (org-columns--capture-view (plist-get params :maxlevel) + (plist-get params :match) (plist-get params :skip-empty-rows) + (plist-get params :exclude-tags) (plist-get params :format) view-pos)))))) (when table @@ -1429,14 +1505,6 @@ PARAMS is a property list of parameters: (concat "\\_" (make-string (* 2 (1- level)) ?\s) item) item)))) (push (cdr row) new-table)))) - (when (plist-get params :width) - (setq table - (append table - (list - (mapcar (lambda (spec) - (let ((w (nth 2 spec))) - (if w (format "<%d>" (max 3 w)) ""))) - org-columns-current-fmt-compiled))))) (when (plist-get params :vlines) (setq table (let ((size (length org-columns-current-fmt-compiled))) @@ -1482,6 +1550,7 @@ PARAMS is a property list of parameters: (id))))) (org-update-dblock)) +(org-dynamic-block-define "columnview" #'org-columns-insert-dblock) ;;; Column view in the agenda @@ -1497,7 +1566,9 @@ PARAMS is a property list of parameters: (let* ((org-columns--time (float-time)) (fmt (cond - ((bound-and-true-p org-agenda-overriding-columns-format)) + ((bound-and-true-p org-overriding-columns-format)) + ((bound-and-true-p org-local-columns-format)) + ((bound-and-true-p org-columns-default-format-for-agenda)) ((let ((m (org-get-at-bol 'org-hd-marker))) (and m (or (org-entry-get m "COLUMNS" t) @@ -1616,8 +1687,8 @@ This will add overlays to the date lines, to show the summary for each day." (let ((b (find-buffer-visiting file))) (with-current-buffer (or (buffer-base-buffer b) b) (org-with-wide-buffer - (org-with-silent-modifications - (remove-text-properties (point-min) (point-max) '(org-summaries t))) + (with-silent-modifications + (remove-text-properties (point-min) (point-max) '(org-summaries t))) (goto-char (point-min)) (org-columns-get-format-and-top-level) (dolist (spec fmt) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index bb927fedf93..4446a169d7a 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -25,34 +25,114 @@ ;;; Commentary: ;; This file contains code needed for compatibility with older -;; versions of GNU Emacs. +;; versions of GNU Emacs and integration with other packages. ;;; Code: (require 'cl-lib) (require 'org-macs) +(declare-function org-agenda-diary-entry "org-agenda") +(declare-function org-agenda-maybe-redo "org-agenda" ()) +(declare-function org-agenda-remove-restriction-lock "org-agenda" (&optional noupdate)) +(declare-function org-align-tags "org" (&optional all)) +(declare-function org-at-heading-p "org" (&optional ignored)) (declare-function org-at-table.el-p "org" ()) (declare-function org-element-at-point "org-element" ()) +(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-end-of-subtree "org" (&optional invisible-ok to-heading)) -(declare-function org-link-set-parameters "org" (type &rest rest)) +(declare-function org-get-heading "org" (&optional no-tags no-todo no-priority no-comment)) +(declare-function org-get-tags "org" (&optional pos local)) +(declare-function org-link-display-format "ol" (s)) +(declare-function org-link-set-parameters "ol" (type &rest rest)) +(declare-function org-log-into-drawer "org" ()) +(declare-function org-make-tag-string "org" (tags)) +(declare-function org-reduced-level "org" (l)) +(declare-function org-show-context "org" (&optional key)) (declare-function org-table-end "org-table" (&optional table-type)) (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)) +(defvar calendar-mode-map) +(defvar org-complex-heading-regexp) +(defvar org-agenda-diary-file) +(defvar org-agenda-overriding-restriction) +(defvar org-agenda-restriction-lock-overlay) (defvar org-table-any-border-regexp) (defvar org-table-dataline-regexp) (defvar org-table-tab-recognizes-table.el) (defvar org-table1-hline-regexp) + +;;; Emacs < 27.1 compatibility + +(unless (fboundp 'proper-list-p) + ;; `proper-list-p' was added in Emacs 27.1. The function below is + ;; taken from Emacs subr.el 200195e824b^. + (defun proper-list-p (object) + "Return OBJECT's length if it is a proper list, nil otherwise. +A proper list is neither circular nor dotted (i.e., its last cdr +is nil)." + (and (listp object) (ignore-errors (length object))))) + +(if (fboundp 'xor) + ;; `xor' was added in Emacs 27.1. + (defalias 'org-xor #'xor) + (defsubst org-xor (a b) + "Exclusive `or'." + (if a (not b) b))) + +(unless (fboundp 'pcomplete-uniquify-list) + ;; The misspelled variant was made obsolete in Emacs 27.1 + (defalias 'pcomplete-uniquify-list 'pcomplete-uniqify-list)) + +(if (fboundp 'time-convert) + (progn + (defsubst org-time-convert-to-integer (time) + (time-convert time 'integer)) + (defsubst org-time-convert-to-list (time) + (time-convert time 'list))) + (defun org-time-convert-to-integer (time) + (floor (float-time time))) + (defun org-time-convert-to-list (time) + (seconds-to-time (float-time time)))) + + +;;; Emacs < 26.1 compatibility + +(if (fboundp 'line-number-display-width) + (defalias 'org-line-number-display-width 'line-number-display-width) + (defun org-line-number-display-width (&rest _) 0)) + +(if (fboundp 'buffer-hash) + (defalias 'org-buffer-hash 'buffer-hash) + (defun org-buffer-hash () (md5 (current-buffer)))) + +(unless (fboundp 'file-attribute-modification-time) + (defsubst file-attribute-modification-time (attributes) + "The modification time in ATTRIBUTES returned by `file-attributes'. +This is the time of the last change to the file's contents, and +is a list of integers (HIGH LOW USEC PSEC) in the same style +as (current-time)." + (nth 5 attributes))) + +(unless (fboundp 'file-attribute-size) + (defsubst file-attribute-size (attributes) + "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. +This is a floating point number if the size is too large for an integer." + (nth 7 attributes))) + + ;;; Emacs < 25.1 compatibility (when (< emacs-major-version 25) (defalias 'outline-hide-entry 'hide-entry) (defalias 'outline-hide-sublevels 'hide-sublevels) (defalias 'outline-hide-subtree 'hide-subtree) - (defalias 'outline-show-all 'show-all) (defalias 'outline-show-branches 'show-branches) (defalias 'outline-show-children 'show-children) (defalias 'outline-show-entry 'show-entry) @@ -72,11 +152,49 @@ (and (memq system-type '(windows-nt ms-dos)) (= lastc ?\\)))))) +;; `string-collate-lessp' is new in Emacs 25. +(if (fboundp 'string-collate-lessp) + (defalias 'org-string-collate-lessp + 'string-collate-lessp) + (defun org-string-collate-lessp (s1 s2 &rest _) + "Return non-nil if STRING1 is less than STRING2 in lexicographic order. +Case is significant." + (string< s1 s2))) + +;; The time- functions below translate nil to `current-time` and +;; accept an integer as of Emacs 25. `decode-time` and +;; `format-time-string` accept nil on Emacs 24 but don't accept an +;; integer until Emacs 25. +(if (< emacs-major-version 25) + (let ((convert + (lambda (time) + (cond ((not time) (current-time)) + ((numberp time) (seconds-to-time time)) + (t time))))) + (defun org-decode-time (&optional time) + (decode-time (funcall convert time))) + (defun org-format-time-string (format-string &optional time universal) + (format-time-string format-string (funcall convert time) universal)) + (defun org-time-add (a b) + (time-add (funcall convert a) (funcall convert b))) + (defun org-time-subtract (a b) + (time-subtract (funcall convert a) (funcall convert b))) + (defun org-time-since (time) + (time-since (funcall convert time))) + (defun org-time-less-p (t1 t2) + (time-less-p (funcall convert t1) (funcall convert t2)))) + (defalias 'org-decode-time 'decode-time) + (defalias 'org-format-time-string 'format-time-string) + (defalias 'org-time-add 'time-add) + (defalias 'org-time-subtract 'time-subtract) + (defalias 'org-time-since 'time-since) + (defalias 'org-time-less-p 'time-less-p)) + ;;; Obsolete aliases (remove them after the next major release). ;;;; XEmacs compatibility, now removed. -(define-obsolete-function-alias 'org-activate-mark 'activate-mark) +(define-obsolete-function-alias 'org-activate-mark 'activate-mark "Org 9.0") (define-obsolete-function-alias 'org-add-hook 'add-hook "Org 9.0") (define-obsolete-function-alias 'org-bound-and-true-p 'bound-and-true-p "Org 9.0") (define-obsolete-function-alias 'org-decompose-region 'decompose-region "Org 9.0") @@ -91,6 +209,7 @@ (define-obsolete-function-alias 'org-match-string-no-properties 'match-string-no-properties "Org 9.0") (define-obsolete-function-alias 'org-propertize 'propertize "Org 9.0") (define-obsolete-function-alias 'org-select-frame-set-input-focus 'select-frame-set-input-focus "Org 9.0") +(define-obsolete-function-alias 'org-file-remote-p 'file-remote-p "Org 9.2") (defmacro org-re (s) "Replace posix classes in regular expression S." @@ -177,6 +296,24 @@ Counting starts at 1." 'org-activate-links "Org 9.0") (define-obsolete-function-alias 'org-activate-plain-links 'ignore "Org 9.0") (define-obsolete-function-alias 'org-activate-angle-links 'ignore "Org 9.0") +(define-obsolete-function-alias 'org-remove-double-quotes 'org-strip-quotes "Org 9.0") +(define-obsolete-function-alias 'org-get-indentation + 'current-indentation "Org 9.2") +(define-obsolete-function-alias 'org-capture-member 'org-capture-get "Org 9.2") +(define-obsolete-function-alias 'org-remove-from-invisibility-spec + 'remove-from-invisibility-spec "Org 9.2") + +(define-obsolete-variable-alias 'org-effort-durations 'org-duration-units + "Org 9.2") + +(define-obsolete-function-alias 'org-toggle-latex-fragment 'org-latex-preview + "Org 9.3") + +(define-obsolete-function-alias 'org-remove-latex-fragment-image-overlays + 'org-clear-latex-preview "Org 9.3") + +(define-obsolete-variable-alias 'org-attach-directory + 'org-attach-id-dir "Org 9.3") (defun org-in-fixed-width-region-p () "Non-nil if point in a fixed-width region." @@ -228,9 +365,10 @@ See `org-link-parameters' for documentation on the other parameters." (make-obsolete 'org-add-link-type "use `org-link-set-parameters' instead." "Org 9.0") +;;;; Functions unused in Org core. (defun org-table-recognize-table.el () "If there is a table.el table nearby, recognize it and move into it." - (when (and org-table-tab-recognizes-table.el (org-at-table.el-p)) + (when (org-at-table.el-p) (beginning-of-line) (unless (or (looking-at org-table-dataline-regexp) (not (looking-at org-table1-hline-regexp))) @@ -246,19 +384,33 @@ See `org-link-parameters' for documentation on the other parameters." (message "recognizing table.el table...done"))) (error "This should not happen")))) -;; Not used by Org core since commit 6d1e3082, Feb 2010. +;; Not used since commit 6d1e3082, Feb 2010. (make-obsolete 'org-table-recognize-table.el - "please notify the org mailing list if you use this function." + "please notify Org mailing list if you use this function." "Org 9.0") +(defmacro org-preserve-lc (&rest body) + (declare (debug (body)) + (obsolete "please notify Org mailing list if you use this function." + "Org 9.2")) + (org-with-gensyms (line col) + `(let ((,line (org-current-line)) + (,col (current-column))) + (unwind-protect + (progn ,@body) + (org-goto-line ,line) + (org-move-to-column ,col))))) + +(defun org-version-check (version &rest _) + "Non-nil if VERSION is lower (older) than `emacs-version'." + (declare (obsolete "use `version<' or `fboundp' instead." + "Org 9.2")) + (version< version emacs-version)) + (defun org-remove-angle-brackets (s) (org-unbracket-string "<" ">" s)) (make-obsolete 'org-remove-angle-brackets 'org-unbracket-string "Org 9.0") -(defun org-remove-double-quotes (s) - (org-unbracket-string "\"" "\"" s)) -(make-obsolete 'org-remove-double-quotes 'org-unbracket-string "Org 9.0") - (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. @@ -344,16 +496,137 @@ use of this function is for the stuck project list." (define-obsolete-variable-alias 'org-texinfo-def-table-markup 'org-texinfo-table-default-markup "Org 9.1") -;;; The function was made obsolete by commit 65399674d5 of 2013-02-22. -;;; This make-obsolete call was added 2016-09-01. +(define-obsolete-variable-alias 'org-agenda-overriding-columns-format + 'org-overriding-columns-format "Org 9.2.2") + +(define-obsolete-variable-alias 'org-doi-server-url + 'org-link-doi-server-url "Org 9.3") + +(define-obsolete-variable-alias 'org-email-link-description-format + 'org-link-email-description-format "Org 9.3") + +(define-obsolete-variable-alias 'org-make-link-description-function + 'org-link-make-description-function "Org 9.3") + +(define-obsolete-variable-alias 'org-from-is-user-regexp + 'org-link-from-user-regexp "Org 9.3") + +(define-obsolete-variable-alias 'org-descriptive-links + 'org-link-descriptive "Org 9.3") + +(define-obsolete-variable-alias 'org-context-in-file-links + 'org-link-context-for-files "Org 9.3") + +(define-obsolete-variable-alias 'org-keep-stored-link-after-insertion + 'org-link-keep-stored-after-insertion "Org 9.3") + +(define-obsolete-variable-alias 'org-display-internal-link-with-indirect-buffer + 'org-link-use-indirect-buffer-for-internals "Org 9.3") + +(define-obsolete-variable-alias 'org-confirm-shell-link-function + 'org-link-shell-confirm-function "Org 9.3") + +(define-obsolete-variable-alias 'org-confirm-shell-link-not-regexp + 'org-link-shell-skip-confirm-regexp "Org 9.3") + +(define-obsolete-variable-alias 'org-confirm-elisp-link-function + 'org-link-elisp-confirm-function "Org 9.3") + +(define-obsolete-variable-alias 'org-confirm-elisp-link-not-regexp + 'org-link-elisp-skip-confirm-regexp "Org 9.3") + +(define-obsolete-function-alias 'org-file-complete-link + 'org-link-complete-file "Org 9.3") + +(define-obsolete-function-alias 'org-email-link-description + 'org-link-email-description "Org 9.3") + +(define-obsolete-function-alias 'org-make-link-string + 'org-link-make-string "Org 9.3") + +(define-obsolete-function-alias 'org-store-link-props + 'org-link-store-props "Org 9.3") + +(define-obsolete-function-alias 'org-add-link-props + 'org-link-add-props "Org 9.3") + +(define-obsolete-function-alias 'org-make-org-heading-search-string + 'org-link-heading-search-string "Org 9.3") + +(define-obsolete-function-alias 'org-make-link-regexps + 'org-link-make-regexps "Org 9.3") + +(define-obsolete-variable-alias 'org-angle-link-re + 'org-link-angle-re "Org 9.3") + +(define-obsolete-variable-alias 'org-plain-link-re + 'org-link-plain-re "Org 9.3") + +(define-obsolete-variable-alias 'org-bracket-link-regexp + 'org-link-bracket-re "Org 9.3") + +(define-obsolete-variable-alias 'org-bracket-link-analytic-regexp + 'org-link-bracket-re "Org 9.3") + +(define-obsolete-variable-alias 'org-any-link-re + 'org-link-any-re "Org 9.3") + +(define-obsolete-function-alias 'org-open-link-from-string + 'org-link-open-from-string "Org 9.3") + +(define-obsolete-function-alias 'org-add-angle-brackets + 'org-link-add-angle-brackets "Org 9.3") + +;; The function was made obsolete by commit 65399674d5 of 2013-02-22. +;; This make-obsolete call was added 2016-09-01. (make-obsolete 'org-capture-import-remember-templates "use the `org-capture-templates' variable instead." "Org 9.0") +(defun org-show-block-all () + "Unfold all blocks in the current buffer." + (interactive) + (remove-overlays nil nil 'invisible 'org-hide-block)) + +(make-obsolete 'org-show-block-all + "use `org-show-all' instead." + "Org 9.2") + +(define-obsolete-function-alias 'org-get-tags-at 'org-get-tags "Org 9.2") + +(defun org-get-local-tags () + "Get a list of tags defined in the current headline." + (declare (obsolete "use `org-get-tags' instead." "Org 9.2")) + (org-get-tags nil 'local)) + +(defun org-get-local-tags-at (&optional pos) + "Get a list of tags defined in the current headline." + (declare (obsolete "use `org-get-tags' instead." "Org 9.2")) + (org-get-tags pos 'local)) + +(defun org-get-tags-string () + "Get the TAGS string in the current headline." + (declare (obsolete "use `org-make-tag-string' instead." "Org 9.2")) + (org-make-tag-string (org-get-tags nil t))) + +(define-obsolete-function-alias 'org-set-tags-to 'org-set-tags "Org 9.2") + +(defun org-align-all-tags () + "Align the tags in all headings." + (declare (obsolete "use `org-align-tags' instead." "Org 9.2")) + (org-align-tags t)) + +(defmacro org-with-silent-modifications (&rest body) + (declare (obsolete "use `with-silent-modifications' instead." "Org 9.2") + (debug (body))) + `(with-silent-modifications ,@body)) + +(define-obsolete-function-alias 'org-babel-strip-quotes + 'org-strip-quotes "Org 9.2") ;;;; Obsolete link types -(eval-after-load 'org +(eval-after-load 'ol '(progn (org-link-set-parameters "file+emacs") ;since Org 9.0 (org-link-set-parameters "file+sys"))) ;since Org 9.0 @@ -362,38 +635,6 @@ use of this function is for the stuck project list." ;;; Miscellaneous functions -;; `xor' was added in Emacs 27.1. -(defalias 'org-xor - (if (fboundp 'xor) - #'xor - (lambda (a b) - "Exclusive or." - (if a (not b) b)))) - -(defun org-version-check (version feature level) - (let* ((v1 (mapcar 'string-to-number (split-string version "[.]"))) - (v2 (mapcar 'string-to-number (split-string emacs-version "[.]"))) - (rmaj (or (nth 0 v1) 99)) - (rmin (or (nth 1 v1) 99)) - (rbld (or (nth 2 v1) 99)) - (maj (or (nth 0 v2) 0)) - (min (or (nth 1 v2) 0)) - (bld (or (nth 2 v2) 0))) - (if (or (< maj rmaj) - (and (= maj rmaj) - (< min rmin)) - (and (= maj rmaj) - (= min rmin) - (< bld rbld))) - (if (eq level :predicate) - ;; just return if we have the version - nil - (let ((msg (format "Emacs %s or greater is recommended for %s" - version feature))) - (display-warning 'org msg level) - t)) - t))) - (defun org-get-x-clipboard (value) "Get the value of the X or Windows clipboard." (cond ((and (eq window-system 'x) @@ -407,38 +648,13 @@ use of this function is for the stuck project list." ((and (eq window-system 'w32) (fboundp 'w32-get-clipboard-data)) (w32-get-clipboard-data)))) -(defun org-add-props (string plist &rest props) - "Add text properties to entire string, from beginning to end. -PLIST may be a list of properties, PROPS are individual properties and values -that will be added to PLIST. Returns the string that was modified." - (add-text-properties - 0 (length string) (if props (append plist props) plist) string) - string) -(put 'org-add-props 'lisp-indent-function 2) - -(defun org-fit-window-to-buffer (&optional window max-height min-height - shrink-only) - "Fit WINDOW to the buffer, but only if it is not a side-by-side window. -WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are -passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call -`shrink-window-if-larger-than-buffer' instead, the height limit is -ignored in this case." - (cond ((if (fboundp 'window-full-width-p) - (not (window-full-width-p window)) - ;; do nothing if another window would suffer - (> (frame-width) (window-width window)))) - ((and (fboundp 'fit-window-to-buffer) (not shrink-only)) - (fit-window-to-buffer window max-height min-height)) - ((fboundp 'shrink-window-if-larger-than-buffer) - (shrink-window-if-larger-than-buffer window))) - (or window (selected-window))) - ;; `set-transient-map' is only in Emacs >= 24.4 (defalias 'org-set-transient-map (if (fboundp 'set-transient-map) 'set-transient-map 'set-temporary-overlay-map)) + ;;; Region compatibility (defvar org-ignore-region nil @@ -455,20 +671,13 @@ Unlike to `use-region-p', this function also checks (> (point) (region-beginning))) (exchange-point-and-mark))) + ;;; Invisibility compatibility -(defun org-remove-from-invisibility-spec (arg) - "Remove elements from `buffer-invisibility-spec'." - (if (fboundp 'remove-from-invisibility-spec) - (remove-from-invisibility-spec arg) - (if (consp buffer-invisibility-spec) - (setq buffer-invisibility-spec - (delete arg buffer-invisibility-spec))))) - (defun org-in-invisibility-spec-p (arg) "Is ARG a member of `buffer-invisibility-spec'?" - (if (consp buffer-invisibility-spec) - (member arg buffer-invisibility-spec))) + (when (consp buffer-invisibility-spec) + (member arg buffer-invisibility-spec))) (defun org-move-to-column (column &optional force _buffer) "Move to column COLUMN. @@ -487,8 +696,8 @@ Pass COLUMN and FORCE to `move-to-column'." (let ((start 0) (n 1)) (while (string-match "\n" s start) (setq start (match-end 0) n (1+ n))) - (if (and (> (length s) 0) (= (aref s (1- (length s))) ?\n)) - (setq n (1- n))) + (when (and (> (length s) 0) (= (aref s (1- (length s))) ?\n)) + (setq n (1- n))) n)) (defun org-kill-new (string &rest args) @@ -511,16 +720,6 @@ Pass COLUMN and FORCE to `move-to-column'." "Return the local name component of FILE." (or (file-remote-p file 'localname) file)))) -(defmacro org-no-popups (&rest body) - "Suppress popup windows. -Let-bind some variables to nil around BODY to achieve the desired -effect, which variables to use depends on the Emacs version." - (if (org-version-check "24.2.50" "" :predicate) - `(let (pop-up-frames display-buffer-alist) - ,@body) - `(let (pop-up-frames special-display-buffer-names special-display-regexps special-display-function) - ,@body))) - ;;;###autoload (defmacro org-check-version () "Try very hard to provide sensible version strings." @@ -539,13 +738,10 @@ effect, which variables to use depends on the Emacs version." (defun org-release () "N/A") (defun org-git-version () "N/A !!check installation!!")))))) -(defmacro org-with-silent-modifications (&rest body) - (if (fboundp 'with-silent-modifications) - `(with-silent-modifications ,@body) - `(org-unmodified ,@body))) -(def-edebug-spec org-with-silent-modifications (body)) -;; Functions for Emacs < 24.4 compatibility + +;;; Functions for Emacs < 24.4 compatibility + (defun org-define-error (name message) "Define NAME as a new error signal. MESSAGE is a string that will be output to the echo area if such @@ -566,6 +762,341 @@ attention to case differences." (eq t (compare-strings suffix nil nil string start-pos nil ignore-case)))))) + +;;; Integration with and fixes for other packages + +(defgroup org-imenu-and-speedbar nil + "Options concerning imenu and speedbar in Org mode." + :tag "Org Imenu and Speedbar" + :group 'org-structure) + +(defcustom org-imenu-depth 2 + "The maximum level for Imenu access to Org headlines. +This also applied for speedbar access." + :group 'org-imenu-and-speedbar + :type 'integer) + +;;;; Imenu + +(defvar-local org-imenu-markers nil + "All markers currently used by Imenu.") + +(defun org-imenu-get-tree () + "Produce the index for Imenu." + (dolist (x org-imenu-markers) (move-marker x nil)) + (setq org-imenu-markers nil) + (org-with-wide-buffer + (goto-char (point-max)) + (let* ((re (concat "^" (org-get-limited-outline-regexp))) + (subs (make-vector (1+ org-imenu-depth) nil)) + (last-level 0)) + (while (re-search-backward re nil t) + (let ((level (org-reduced-level (funcall outline-level))) + (headline (org-no-properties + (org-link-display-format (org-get-heading t t t t))))) + (when (and (<= level org-imenu-depth) (org-string-nw-p headline)) + (let* ((m (point-marker)) + (item (propertize headline 'org-imenu-marker m 'org-imenu t))) + (push m org-imenu-markers) + (if (>= level last-level) + (push (cons item m) (aref subs level)) + (push (cons item + (cl-mapcan #'identity (cl-subseq subs (1+ level)))) + (aref subs level)) + (cl-loop for i from (1+ level) to org-imenu-depth + do (aset subs i nil))) + (setq last-level level))))) + (aref subs 1)))) + +(eval-after-load "imenu" + '(progn + (add-hook 'imenu-after-jump-hook + (lambda () + (when (derived-mode-p 'org-mode) + (org-show-context 'org-goto)))) + (add-hook 'org-mode-hook + (lambda () + (setq imenu-create-index-function 'org-imenu-get-tree))))) + +;;;; Speedbar + +(defvar org-speedbar-restriction-lock-overlay (make-overlay 1 1) + "Overlay marking the agenda restriction line in speedbar.") +(overlay-put org-speedbar-restriction-lock-overlay + 'face 'org-agenda-restriction-lock) +(overlay-put org-speedbar-restriction-lock-overlay + 'help-echo "Agendas are currently limited to this item.") +(delete-overlay org-speedbar-restriction-lock-overlay) + +(defun org-speedbar-set-agenda-restriction () + "Restrict future agenda commands to the location at point in speedbar. +If there is already a restriction lock at the location, remove it. + +To get rid of the restriction, use `\\[org-agenda-remove-restriction-lock]'." + (interactive) + (require 'org-agenda) + (let (p m tp np dir txt) + (cond + ((setq p (text-property-any (point-at-bol) (point-at-eol) + 'org-imenu t)) + (setq m (get-text-property p 'org-imenu-marker)) + (with-current-buffer (marker-buffer m) + (goto-char m) + (if (and org-agenda-overriding-restriction + (member org-agenda-restriction-lock-overlay + (overlays-at (point)))) + (org-agenda-remove-restriction-lock 'noupdate) + (org-agenda-set-restriction-lock 'subtree)))) + ((setq p (text-property-any (point-at-bol) (point-at-eol) + 'speedbar-function 'speedbar-find-file)) + (setq tp (previous-single-property-change + (1+ p) 'speedbar-function) + np (next-single-property-change + tp 'speedbar-function) + dir (speedbar-line-directory) + txt (buffer-substring-no-properties (or tp (point-min)) + (or np (point-max)))) + (with-current-buffer (find-file-noselect + (let ((default-directory dir)) + (expand-file-name txt))) + (unless (derived-mode-p 'org-mode) + (user-error "Cannot restrict to non-Org mode file")) + (org-agenda-set-restriction-lock 'file))) + (t (user-error "Don't know how to restrict Org mode agenda"))) + (move-overlay org-speedbar-restriction-lock-overlay + (point-at-bol) (point-at-eol)) + (setq current-prefix-arg nil) + (org-agenda-maybe-redo))) + +(defvar speedbar-file-key-map) +(declare-function speedbar-add-supported-extension "speedbar" (extension)) +(eval-after-load "speedbar" + '(progn + (speedbar-add-supported-extension ".org") + (define-key speedbar-file-key-map "<" 'org-speedbar-set-agenda-restriction) + (define-key speedbar-file-key-map "\C-c\C-x<" 'org-speedbar-set-agenda-restriction) + (define-key speedbar-file-key-map ">" 'org-agenda-remove-restriction-lock) + (define-key speedbar-file-key-map "\C-c\C-x>" 'org-agenda-remove-restriction-lock) + (add-hook 'speedbar-visiting-tag-hook + (lambda () (and (derived-mode-p 'org-mode) (org-show-context 'org-goto)))))) + +;;;; Add Log + +(defun org-add-log-current-headline () + "Return current headline or nil. +This function ignores inlinetasks. It is meant to be used as +`add-log-current-defun-function' value." + (org-with-limited-levels (org-get-heading t t t t))) + +;;;; Flyspell + +(defun org--flyspell-object-check-p (element) + "Non-nil when Flyspell can check object at point. +ELEMENT is the element at point." + (let ((object (save-excursion + (when (looking-at-p "\\>") (backward-char)) + (org-element-context element)))) + (cl-case (org-element-type object) + ;; Prevent checks in links due to keybinding conflict with + ;; Flyspell. + ((code entity export-snippet inline-babel-call + inline-src-block line-break latex-fragment link macro + statistics-cookie target timestamp verbatim) + nil) + (footnote-reference + ;; Only in inline footnotes, within the definition. + (and (eq (org-element-property :type object) 'inline) + (< (save-excursion + (goto-char (org-element-property :begin object)) + (search-forward ":" nil t 2)) + (point)))) + (otherwise t)))) + +(defun org-mode-flyspell-verify () + "Function used for `flyspell-generic-check-word-predicate'." + (if (org-at-heading-p) + ;; At a headline or an inlinetask, check title only. This is + ;; faster than relying on `org-element-at-point'. + (and (save-excursion (beginning-of-line) + (and (let ((case-fold-search t)) + (not (looking-at-p "\\*+ END[ \t]*$"))) + (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp)))) + (match-beginning 4) + (>= (point) (match-beginning 4)) + (or (not (match-beginning 5)) + (< (point) (match-beginning 5)))) + (let* ((element (org-element-at-point)) + (post-affiliated (org-element-property :post-affiliated element))) + (cond + ;; Ignore checks in all affiliated keywords but captions. + ((< (point) post-affiliated) + (and (save-excursion + (beginning-of-line) + (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)))) + (and drawer + (eq (compare-strings + log nil nil + (org-element-property :drawer-name drawer) nil nil t) + t))))) + nil) + (t + (cl-case (org-element-type element) + ((comment quote-section) t) + (comment-block + ;; Allow checks between block markers, not on them. + (and (> (line-beginning-position) post-affiliated) + (save-excursion + (end-of-line) + (skip-chars-forward " \r\t\n") + (< (point) (org-element-property :end element))))) + ;; Arbitrary list of keywords where checks are meaningful. + ;; Make sure point is on the value part of the element. + (keyword + (and (member (org-element-property :key element) + '("DESCRIPTION" "TITLE")) + (save-excursion + (search-backward ":" (line-beginning-position) t)))) + ;; Check is globally allowed in paragraphs verse blocks and + ;; 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))) + (and cbeg (>= (point) cbeg) (< (point) cend) + (org--flyspell-object-check-p element)))))))))) +(put 'org-mode 'flyspell-mode-predicate 'org-mode-flyspell-verify) + +(defun org-remove-flyspell-overlays-in (beg end) + "Remove flyspell overlays in region." + (and (bound-and-true-p flyspell-mode) + (fboundp 'flyspell-delete-region-overlays) + (flyspell-delete-region-overlays beg end))) + +(defvar flyspell-delayed-commands) +(eval-after-load "flyspell" + '(add-to-list 'flyspell-delayed-commands 'org-self-insert-command)) + +;;;; Bookmark + +(defun org-bookmark-jump-unhide () + "Unhide the current position, to show the bookmark location." + (and (derived-mode-p 'org-mode) + (or (org-invisible-p) + (save-excursion (goto-char (max (point-min) (1- (point)))) + (org-invisible-p))) + (org-show-context 'bookmark-jump))) + +;; Make `bookmark-jump' shows the jump location if it was hidden. +(eval-after-load "bookmark" + '(if (boundp 'bookmark-after-jump-hook) + ;; We can use the hook + (add-hook 'bookmark-after-jump-hook 'org-bookmark-jump-unhide) + ;; Hook not available, use advice + (defadvice bookmark-jump (after org-make-visible activate) + "Make the position visible." + (org-bookmark-jump-unhide)))) + +;;;; Calendar + +(defcustom org-calendar-to-agenda-key 'default + "Key to be installed in `calendar-mode-map' for switching to the agenda. + +The command `org-calendar-goto-agenda' will be bound to this key. + +When set to `default', bind the function to `c', but only if it is +available in the Calendar keymap. This is the default choice because +`c' can then be used to switch back and forth between agenda and calendar. + +When nil, `org-calendar-goto-agenda' is not bound to any key." + :group 'org-agenda + :type '(choice + (const :tag "Bind to `c' if available" default) + (key-sequence :tag "Other binding") + (const :tag "No binding" nil)) + :safe (lambda (v) (or (symbolp v) (stringp v))) + :package-version '(Org . "9.2")) + +(defcustom org-calendar-insert-diary-entry-key [?i] + "The key to be installed in `calendar-mode-map' for adding diary entries. +This option is irrelevant until `org-agenda-diary-file' has been configured +to point to an Org file. When that is the case, the command +`org-agenda-diary-entry' will be bound to the key given here, by default +`i'. In the calendar, `i' normally adds entries to `diary-file'. So +if you want to continue doing this, you need to change this to a different +key." + :group 'org-agenda + :type 'sexp) + +(defun org--setup-calendar-bindings () + "Bind Org functions in Calendar keymap." + (pcase org-calendar-to-agenda-key + (`nil nil) + ((and key (pred stringp)) + (local-set-key (kbd key) #'org-calendar-goto-agenda)) + ((guard (not (lookup-key calendar-mode-map "c"))) + (local-set-key "c" #'org-calendar-goto-agenda)) + (_ nil)) + (unless (eq org-agenda-diary-file 'diary-file) + (local-set-key org-calendar-insert-diary-entry-key + #'org-agenda-diary-entry))) + +(eval-after-load "calendar" + '(add-hook 'calendar-mode-hook #'org--setup-calendar-bindings)) + +;;;; Saveplace + +;; Make sure saveplace shows the location if it was hidden +(eval-after-load "saveplace" + '(defadvice save-place-find-file-hook (after org-make-visible activate) + "Make the position visible." + (org-bookmark-jump-unhide))) + +;;;; Ecb + +;; Make sure ecb shows the location if it was hidden +(eval-after-load "ecb" + '(defadvice ecb-method-clicked (after esf/org-show-context activate) + "Make hierarchy visible when jumping into location from ECB tree buffer." + (when (derived-mode-p 'org-mode) + (org-show-context)))) + +;;;; Simple + +(defun org-mark-jump-unhide () + "Make the point visible with `org-show-context' after jumping to the mark." + (when (and (derived-mode-p 'org-mode) + (org-invisible-p)) + (org-show-context 'mark-goto))) + +(eval-after-load "simple" + '(defadvice pop-to-mark-command (after org-make-visible activate) + "Make the point visible with `org-show-context'." + (org-mark-jump-unhide))) + +(eval-after-load "simple" + '(defadvice exchange-point-and-mark (after org-make-visible activate) + "Make the point visible with `org-show-context'." + (org-mark-jump-unhide))) + +(eval-after-load "simple" + '(defadvice pop-global-mark (after org-make-visible activate) + "Make the point visible with `org-show-context'." + (org-mark-jump-unhide))) + +;;;; Session + +;; Make "session.el" ignore our circular variable. +(defvar session-globals-exclude) +(eval-after-load "session" + '(add-to-list 'session-globals-exclude 'org-mark-ring)) + (provide 'org-compat) ;;; org-compat.el ends here diff --git a/lisp/org/org-crypt.el b/lisp/org/org-crypt.el index 9cd76c9eca5..1bdf623e570 100644 --- a/lisp/org/org-crypt.el +++ b/lisp/org/org-crypt.el @@ -190,7 +190,7 @@ See `org-crypt-disable-auto-save'." (error (insert contents) (error (nth 1 err))))) (when folded (goto-char start-heading) - (outline-hide-subtree)) + (org-flag-subtree t)) nil))))) (defun org-decrypt-entry () diff --git a/lisp/org/org-duration.el b/lisp/org/org-duration.el index 770c72fd676..e350bc74b51 100644 --- a/lisp/org/org-duration.el +++ b/lisp/org/org-duration.el @@ -51,7 +51,6 @@ (require 'cl-lib) (require 'org-macs) -(declare-function org-trim "org" (s &optional keep-lead)) ;;; Public variables diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index 04e2fda55e3..56b3cc4131f 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -58,10 +58,55 @@ ;;; Code: -(require 'org) (require 'avl-tree) (require 'cl-lib) - +(require 'ol) +(require 'org) +(require 'org-compat) +(require 'org-entities) +(require 'org-footnote) +(require 'org-list) +(require 'org-macs) +(require 'org-table) + +(declare-function org-at-heading-p "org" (&optional _)) +(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading)) +(declare-function org-escape-code-in-string "org-src" (s)) +(declare-function org-find-visible "org" ()) +(declare-function org-macro-escape-arguments "org-macro" (&rest args)) +(declare-function org-macro-extract-arguments "org-macro" (s)) +(declare-function org-reduced-level "org" (l)) +(declare-function org-unescape-code-in-string "org-src" (s)) +(declare-function outline-next-heading "outline" ()) +(declare-function outline-previous-heading "outline" ()) + +(defvar org-archive-tag) +(defvar org-clock-line-re) +(defvar org-closed-string) +(defvar org-comment-string) +(defvar org-complex-heading-regexp) +(defvar org-dblock-start-re) +(defvar org-deadline-string) +(defvar org-done-keywords) +(defvar org-drawer-regexp) +(defvar org-edit-src-content-indentation) +(defvar org-emph-re) +(defvar org-emphasis-regexp-components) +(defvar org-keyword-time-not-clock-regexp) +(defvar org-match-substring-regexp) +(defvar org-odd-levels-only) +(defvar org-outline-regexp-bol) +(defvar org-planning-line-re) +(defvar org-property-drawer-re) +(defvar org-property-format) +(defvar org-property-re) +(defvar org-scheduled-string) +(defvar org-src-preserve-indentation) +(defvar org-tags-column) +(defvar org-time-stamp-formats) +(defvar org-todo-regexp) +(defvar org-ts-regexp-both) +(defvar org-verbatim-re) ;;; Definitions And Rules @@ -91,7 +136,7 @@ specially in `org-element--object-lex'.") (setq org-element-paragraph-separate (concat "^\\(?:" ;; Headlines, inlinetasks. - org-outline-regexp "\\|" + "\\*+ " "\\|" ;; Footnote definitions. "\\[fn:[-_[:word:]]+\\]" "\\|" ;; Diary sexps. @@ -117,7 +162,7 @@ specially in `org-element--object-lex'.") ;; LaTeX environments. "\\\\begin{\\([A-Za-z0-9*]+\\)}" "\\|" ;; Clock lines. - (regexp-quote org-clock-string) "\\|" + "CLOCK:" "\\|" ;; Lists. (let ((term (pcase org-plain-list-ordered-item-terminator (?\) ")") (?. "\\.") (_ "[.)]"))) @@ -307,8 +352,9 @@ Don't modify it, set `org-element-affiliated-keywords' instead.") (strike-through ,@standard-set) (subscript ,@standard-set) (superscript ,@standard-set) - ;; Ignore inline babel call and inline src block as formulas are - ;; possible. Also ignore line breaks and statistics cookies. + ;; Ignore inline babel call and inline source block as formulas + ;; are possible. Also ignore line breaks and statistics + ;; cookies. (table-cell bold code entity export-snippet footnote-reference italic latex-fragment link macro radio-target strike-through subscript superscript target timestamp underline verbatim) @@ -491,6 +537,7 @@ objects, or a strings. The function takes care of setting `:parent' property for CHILD. Return parent element." + (declare (indent 1)) (if (not children) parent ;; Link every child to PARENT. If PARENT is nil, it is a secondary ;; string: parent is the list itself. @@ -677,7 +724,7 @@ Assume point is at the beginning of the block." (defun org-element-center-block-interpreter (_ contents) "Interpret a center-block element as Org syntax. CONTENTS is the contents of the element." - (format "#+BEGIN_CENTER\n%s#+END_CENTER" contents)) + (format "#+begin_center\n%s#+end_center" contents)) ;;;; Drawer @@ -787,7 +834,7 @@ Assume point is at beginning of dynamic block." (defun org-element-dynamic-block-interpreter (dynamic-block contents) "Interpret DYNAMIC-BLOCK element as Org syntax. CONTENTS is the contents of the element." - (format "#+BEGIN: %s%s\n%s#+END:" + (format "#+begin: %s%s\n%s#+end:" (org-element-property :block-name dynamic-block) (let ((args (org-element-property :arguments dynamic-block))) (if args (concat " " args) "")) @@ -812,7 +859,8 @@ their value. Return a list whose CAR is `footnote-definition' and CDR is a plist containing `:label', `:begin' `:end', `:contents-begin', -`:contents-end', `:post-blank' and `:post-affiliated' keywords. +`:contents-end', `:pre-blank',`:post-blank' and +`:post-affiliated' keywords. Assume point is at the beginning of the footnote definition." (save-excursion @@ -838,12 +886,16 @@ Assume point is at the beginning of the footnote definition." ((eq ?* (char-after (match-beginning 0))) (match-beginning 0)) (t (skip-chars-forward " \r\t\n" limit) (if (= limit (point)) limit (line-beginning-position)))))) + (pre-blank 0) (contents-begin (progn (search-forward "]") (skip-chars-forward " \r\t\n" end) (cond ((= (point) end) nil) ((= (line-beginning-position) post-affiliated) (point)) - (t (line-beginning-position))))) + (t + (setq pre-blank + (count-lines (line-beginning-position) begin)) + (line-beginning-position))))) (contents-end (progn (goto-char end) (skip-chars-backward " \r\t\n") @@ -855,6 +907,7 @@ Assume point is at the beginning of the footnote definition." :end end :contents-begin contents-begin :contents-end (and contents-begin contents-end) + :pre-blank pre-blank :post-blank (count-lines contents-end end) :post-affiliated post-affiliated) (cdr affiliated)))))) @@ -862,9 +915,18 @@ Assume point is at the beginning of the footnote definition." (defun org-element-footnote-definition-interpreter (footnote-definition contents) "Interpret FOOTNOTE-DEFINITION element as Org syntax. CONTENTS is the contents of the footnote-definition." - (concat (format "[fn:%s]" (org-element-property :label footnote-definition)) - " " - contents)) + (let ((pre-blank + (min (or (org-element-property :pre-blank footnote-definition) + ;; 0 is specific to paragraphs at the beginning of + ;; the footnote definition, so we use 1 as + ;; a fall-back value, which is more universal. + 1) + ;; Footnote ends after more than two consecutive empty + ;; lines: limit ourselves to 2 newline characters. + 2))) + (concat (format "[fn:%s]" (org-element-property :label footnote-definition)) + (if (= pre-blank 0) (concat " " (org-trim contents)) + (concat (make-string pre-blank ?\n) contents))))) ;;;; Headline @@ -911,7 +973,7 @@ Return value is a plist." Return a list whose CAR is `headline' and CDR is a plist containing `:raw-value', `:title', `:begin', `:end', `:pre-blank', `:contents-begin' and `:contents-end', `:level', -`:priority', `:tags', `:todo-keyword',`:todo-type', `:scheduled', +`:priority', `:tags', `:todo-keyword', `:todo-type', `:scheduled', `:deadline', `:closed', `:archivedp', `:commentedp' `:footnote-section-p', `:post-blank' and `:post-affiliated' keywords. @@ -931,10 +993,10 @@ Assume point is at beginning of the headline." (level (prog1 (org-reduced-level (skip-chars-forward "*")) (skip-chars-forward " \t"))) (todo (and org-todo-regexp - (let (case-fold-search) (looking-at org-todo-regexp)) + (let (case-fold-search) (looking-at (concat org-todo-regexp " "))) (progn (goto-char (match-end 0)) (skip-chars-forward " \t") - (match-string 0)))) + (match-string 1)))) (todo-type (and todo (if (member todo org-done-keywords) 'done 'todo))) (priority (and (looking-at "\\[#.\\][ \t]*") @@ -1172,18 +1234,18 @@ CONTENTS is the contents of inlinetask." (concat (make-string (max (- (+ org-tags-column (length task) (length tags))) 1) - ? ) + ?\s) tags)) (t (concat - (make-string (max (- org-tags-column (length task)) 1) ? ) + (make-string (max (- org-tags-column (length task)) 1) ?\s) tags)))) ;; Prefer degenerate inlinetasks when there are no ;; contents. (when contents (concat "\n" contents - (make-string level ?*) " END"))))) + (make-string level ?*) " end"))))) ;;;; Item @@ -1195,8 +1257,8 @@ STRUCT is the structure of the plain list. Return a list whose CAR is `item' and CDR is a plist containing `:bullet', `:begin', `:end', `:contents-begin', `:contents-end', -`:checkbox', `:counter', `:tag', `:structure', `:post-blank' and -`:post-affiliated' keywords. +`:checkbox', `:counter', `:tag', `:structure', `:pre-blank', +`:post-blank' and `:post-affiliated' keywords. When optional argument RAW-SECONDARY-P is non-nil, item's tag, if any, will not be parsed as a secondary string, but as a plain @@ -1223,20 +1285,25 @@ Assume point is at the beginning of the item." (string-to-number (match-string 0 c))))))) (end (progn (goto-char (nth 6 (assq (point) struct))) (if (bolp) (point) (line-beginning-position 2)))) + (pre-blank 0) (contents-begin - (progn (goto-char - ;; Ignore tags in un-ordered lists: they are just - ;; a part of item's body. - (if (and (match-beginning 4) - (save-match-data (string-match "[.)]" bullet))) - (match-beginning 4) - (match-end 0))) - (skip-chars-forward " \r\t\n" end) - (cond ((= (point) end) nil) - ;; If first line isn't empty, contents really - ;; start at the text after item's meta-data. - ((= (line-beginning-position) begin) (point)) - (t (line-beginning-position))))) + (progn + (goto-char + ;; Ignore tags in un-ordered lists: they are just + ;; a part of item's body. + (if (and (match-beginning 4) + (save-match-data (string-match "[.)]" bullet))) + (match-beginning 4) + (match-end 0))) + (skip-chars-forward " \r\t\n" end) + (cond ((= (point) end) nil) + ;; If first line isn't empty, contents really + ;; start at the text after item's meta-data. + ((= (line-beginning-position) begin) (point)) + (t + (setq pre-blank + (count-lines (line-beginning-position) begin)) + (line-beginning-position))))) (contents-end (and contents-begin (progn (goto-char end) (skip-chars-backward " \r\t\n") @@ -1251,6 +1318,7 @@ Assume point is at the beginning of the item." :checkbox checkbox :counter counter :structure struct + :pre-blank pre-blank :post-blank (count-lines (or contents-end begin) end) :post-affiliated begin)))) (org-element-put-property @@ -1266,35 +1334,43 @@ Assume point is at the beginning of the item." (defun org-element-item-interpreter (item contents) "Interpret ITEM element as Org syntax. CONTENTS is the contents of the element." - (let* ((bullet (let ((bullet (org-element-property :bullet item))) - (org-list-bullet-string - (cond ((not (string-match "[0-9a-zA-Z]" bullet)) "- ") - ((eq org-plain-list-ordered-item-terminator ?\)) "1)") - (t "1."))))) - (checkbox (org-element-property :checkbox item)) - (counter (org-element-property :counter item)) - (tag (let ((tag (org-element-property :tag item))) - (and tag (org-element-interpret-data tag)))) - ;; Compute indentation. - (ind (make-string (length bullet) 32)) - (item-starts-with-par-p - (eq (org-element-type (car (org-element-contents item))) - 'paragraph))) - ;; Indent contents. + (let ((tag (pcase (org-element-property :tag item) + (`nil nil) + (tag (format "%s :: " (org-element-interpret-data tag))))) + (bullet + (org-list-bullet-string + (cond + ((not (string-match-p "[0-9a-zA-Z]" + (org-element-property :bullet item))) "- ") + ((eq org-plain-list-ordered-item-terminator ?\)) "1)") + (t "1."))))) (concat bullet - (and counter (format "[@%d] " counter)) - (pcase checkbox + (pcase (org-element-property :counter item) + (`nil nil) + (counter (format "[@%d] " counter))) + (pcase (org-element-property :checkbox item) (`on "[X] ") (`off "[ ] ") (`trans "[-] ") (_ nil)) - (and tag (format "%s :: " tag)) + tag (when contents - (let ((contents (replace-regexp-in-string - "\\(^\\)[ \t]*\\S-" ind contents nil nil 1))) - (if item-starts-with-par-p (org-trim contents) - (concat "\n" contents))))))) + (let* ((ind (make-string (if tag 5 (length bullet)) ?\s)) + (pre-blank + (min (or (org-element-property :pre-blank item) + ;; 0 is specific to paragraphs at the + ;; beginning of the item, so we use 1 as + ;; a fall-back value, which is more universal. + 1) + ;; Lists ends after more than two consecutive + ;; empty lines: limit ourselves to 2 newline + ;; characters. + 2)) + (contents (replace-regexp-in-string + "\\(^\\)[ \t]*\\S-" ind contents nil nil 1))) + (if (= pre-blank 0) (org-trim contents) + (concat (make-string pre-blank ?\n) contents))))))) ;;;; Plain List @@ -1516,7 +1592,7 @@ Assume point is at the beginning of the block." (defun org-element-quote-block-interpreter (_ contents) "Interpret quote-block element as Org syntax. CONTENTS is the contents of the element." - (format "#+BEGIN_QUOTE\n%s#+END_QUOTE" contents)) + (format "#+begin_quote\n%s#+end_quote" contents)) ;;;; Section @@ -1602,7 +1678,7 @@ Assume point is at the beginning of the block." "Interpret SPECIAL-BLOCK element as Org syntax. CONTENTS is the contents of the element." (let ((block-type (org-element-property :type special-block))) - (format "#+BEGIN_%s\n%s#+END_%s" block-type contents block-type))) + (format "#+begin_%s\n%s#+end_%s" block-type contents block-type))) @@ -1670,7 +1746,7 @@ containing `:call', `:inside-header', `:arguments', (defun org-element-babel-call-interpreter (babel-call _) "Interpret BABEL-CALL element as Org syntax." - (concat "#+CALL: " + (concat "#+call: " (org-element-property :call babel-call) (let ((h (org-element-property :inside-header babel-call))) (and h (format "[%s]" h))) @@ -1692,7 +1768,7 @@ Return a list whose CAR is `clock' and CDR is a plist containing (save-excursion (let* ((case-fold-search nil) (begin (point)) - (value (progn (search-forward org-clock-string (line-end-position) t) + (value (progn (search-forward "CLOCK:" (line-end-position) t) (skip-chars-forward " \t") (org-element-timestamp-parser))) (duration (and (search-forward " => " (line-end-position) t) @@ -1717,7 +1793,7 @@ Return a list whose CAR is `clock' and CDR is a plist containing (defun org-element-clock-interpreter (clock _) "Interpret CLOCK element as Org syntax." - (concat org-clock-string " " + (concat "CLOCK: " (org-element-timestamp-interpreter (org-element-property :value clock) nil) (let ((duration (org-element-property :duration clock))) @@ -1824,7 +1900,7 @@ Assume point is at comment block beginning." (defun org-element-comment-block-interpreter (comment-block _) "Interpret COMMENT-BLOCK element as Org syntax." - (format "#+BEGIN_COMMENT\n%s#+END_COMMENT" + (format "#+begin_comment\n%s#+end_comment" (org-element-normalize-string (org-remove-indentation (org-element-property :value comment-block))))) @@ -1951,15 +2027,22 @@ containing `:begin', `:end', `:number-lines', `:preserve-indent', (defun org-element-example-block-interpreter (example-block _) "Interpret EXAMPLE-BLOCK element as Org syntax." (let ((switches (org-element-property :switches example-block)) - (value (org-element-property :value example-block))) - (concat "#+BEGIN_EXAMPLE" (and switches (concat " " switches)) "\n" - (org-element-normalize-string - (org-escape-code-in-string - (if (or org-src-preserve-indentation - (org-element-property :preserve-indent example-block)) - value - (org-remove-indentation value)))) - "#+END_EXAMPLE"))) + (value + (let ((val (org-element-property :value example-block))) + (cond + ((or org-src-preserve-indentation + (org-element-property :preserve-indent example-block)) + val) + ((= 0 org-edit-src-content-indentation) + (org-remove-indentation val)) + (t + (let ((ind (make-string org-edit-src-content-indentation ?\s))) + (replace-regexp-in-string "^[ \t]*\\S-" + (concat ind "\\&") + (org-remove-indentation val)))))))) + (concat "#+begin_example" (and switches (concat " " switches)) "\n" + (org-element-normalize-string (org-escape-code-in-string value)) + "#+end_example"))) ;;;; Export Block @@ -2012,7 +2095,7 @@ Assume point is at export-block beginning." (defun org-element-export-block-interpreter (export-block _) "Interpret EXPORT-BLOCK element as Org syntax." - (format "#+BEGIN_EXPORT %s\n%s#+END_EXPORT" + (format "#+begin_export %s\n%s#+end_export" (org-element-property :type export-block) (org-element-property :value export-block))) @@ -2035,26 +2118,22 @@ Assume point is at the beginning of the fixed-width area." (save-excursion (let* ((begin (car affiliated)) (post-affiliated (point)) - value (end-area (progn (while (and (< (point) limit) (looking-at "[ \t]*:\\( \\|$\\)")) - ;; Accumulate text without starting colons. - (setq value - (concat value - (buffer-substring-no-properties - (match-end 0) (point-at-eol)) - "\n")) (forward-line)) - (point))) + (if (bolp) (line-end-position 0) (point)))) (end (progn (skip-chars-forward " \r\t\n" limit) (if (eobp) (point) (line-beginning-position))))) (list 'fixed-width (nconc (list :begin begin :end end - :value value + :value (replace-regexp-in-string + "^[ \t]*: ?" "" + (buffer-substring-no-properties post-affiliated + end-area)) :post-blank (count-lines end-area end) :post-affiliated post-affiliated) (cdr affiliated)))))) @@ -2062,10 +2141,7 @@ Assume point is at the beginning of the fixed-width area." (defun org-element-fixed-width-interpreter (fixed-width _) "Interpret FIXED-WIDTH element as Org syntax." (let ((value (org-element-property :value fixed-width))) - (and value - (replace-regexp-in-string - "^" ": " - (if (string-match "\n\\'" value) (substring value 0 -1) value))))) + (and value (replace-regexp-in-string "^" ": " value)))) ;;;; Horizontal Rule @@ -2139,7 +2215,7 @@ containing `:key', `:value', `:begin', `:end', `:post-blank' and (defun org-element-keyword-interpreter (keyword _) "Interpret KEYWORD element as Org syntax." (format "#+%s: %s" - (org-element-property :key keyword) + (downcase (org-element-property :key keyword)) (org-element-property :value keyword))) @@ -2369,7 +2445,7 @@ containing `:closed', `:deadline', `:scheduled', `:begin', ;;;; Src Block (defun org-element-src-block-parser (limit affiliated) - "Parse a src block. + "Parse a source block. LIMIT bounds the search. AFFILIATED is a list of which CAR is the buffer position at the beginning of the first affiliated @@ -2425,7 +2501,7 @@ Assume point is at the beginning of the block." (string-match "-l +\"\\([^\"\n]+\\)\"" switches) (match-string 1 switches))) ;; Should labels be retained in (or stripped from) - ;; src blocks? + ;; source blocks? (retain-labels (or (not switches) (not (string-match "-r\\>" switches)) @@ -2480,14 +2556,14 @@ Assume point is at the beginning of the block." (org-remove-indentation val)) (t (let ((ind (make-string org-edit-src-content-indentation ?\s))) - (replace-regexp-in-string - "^" ind (org-remove-indentation val)))))))) - (concat (format "#+BEGIN_SRC%s\n" - (concat (and lang (concat " " lang)) - (and switches (concat " " switches)) - (and params (concat " " params)))) - (org-element-normalize-string (org-escape-code-in-string value)) - "#+END_SRC"))) + (replace-regexp-in-string "^[ \t]*\\S-" + (concat ind "\\&") + (org-remove-indentation val)))))))) + (format "#+begin_src%s\n%s#+end_src" + (concat (and lang (concat " " lang)) + (and switches (concat " " switches)) + (and params (concat " " params))) + (org-element-normalize-string (org-escape-code-in-string value))))) ;;;; Table @@ -2635,7 +2711,7 @@ Assume point is at beginning of the block." (defun org-element-verse-block-interpreter (_ contents) "Interpret verse-block element as Org syntax. CONTENTS is verse block contents." - (format "#+BEGIN_VERSE\n%s#+END_VERSE" contents)) + (format "#+begin_verse\n%s#+end_verse" contents)) @@ -2803,7 +2879,7 @@ Assume point is at the beginning of the snippet." When at a footnote reference, return a list whose car is `footnote-reference' and cdr a plist with `:label', `:type', -`:begin', `:end', `:content-begin', `:contents-end' and +`:begin', `:end', `:contents-begin', `:contents-end' and `:post-blank' as keywords. Otherwise, return nil." (when (looking-at org-footnote-re) (let ((closing (with-syntax-table org-element--pair-square-table @@ -2899,7 +2975,7 @@ When at an inline source block, return a list whose car is `:language', `:value', `:parameters' and `:post-blank' as keywords. Otherwise, return nil. -Assume point is at the beginning of the inline src block." +Assume point is at the beginning of the inline source block." (save-excursion (catch :no-object (when (let ((case-fold-search nil)) @@ -3066,13 +3142,13 @@ Assume point is at the beginning of the link." (setq contents-begin (match-beginning 1)) (setq contents-end (match-end 1))) ;; Type 2: Standard link, i.e. [[https://orgmode.org][homepage]] - ((looking-at org-bracket-link-regexp) + ((looking-at org-link-bracket-re) (setq format 'bracket) - (setq contents-begin (match-beginning 3)) - (setq contents-end (match-end 3)) + (setq contents-begin (match-beginning 2)) + (setq contents-end (match-end 2)) (setq link-end (match-end 0)) - ;; RAW-LINK is the original link. Expand any - ;; abbreviation in it. + ;; RAW-LINK is the original link. Decode any encoding. + ;; Expand any abbreviation in it. ;; ;; Also treat any newline character and associated ;; indentation as a single space character. This is not @@ -3083,9 +3159,10 @@ Assume point is at the beginning of the link." ;; [[shell:ls *.org]], which defeats Org's focus on ;; simplicity. (setq raw-link (org-link-expand-abbrev - (replace-regexp-in-string - "[ \t]*\n[ \t]*" " " - (match-string-no-properties 1)))) + (org-link-unescape + (replace-regexp-in-string + "[ \t]*\n[ \t]*" " " + (match-string-no-properties 1))))) ;; Determine TYPE of link and set PATH accordingly. According ;; to RFC 3986, remove whitespaces from URI in external links. ;; In internal ones, treat indentation as a single space. @@ -3115,7 +3192,7 @@ Assume point is at the beginning of the link." (setq type "fuzzy") (setq path raw-link)))) ;; Type 3: Plain link, e.g., https://orgmode.org - ((looking-at org-plain-link-re) + ((looking-at org-link-plain-re) (setq format 'plain) (setq raw-link (match-string-no-properties 0)) (setq type (match-string-no-properties 1)) @@ -3124,7 +3201,7 @@ Assume point is at the beginning of the link." ;; Type 4: Angular link, e.g., <https://orgmode.org>. Unlike to ;; bracket links, follow RFC 3986 and remove any extra ;; whitespace in URI. - ((looking-at org-angle-link-re) + ((looking-at org-link-angle-re) (setq format 'angle) (setq type (match-string-no-properties 1)) (setq link-end (match-end 0)) @@ -3218,15 +3295,18 @@ a plist with `:key', `:args', `:begin', `:end', `:value' and Assume point is at the macro." (save-excursion - (when (looking-at "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\(([ \t\n]*\\([^\000]*?\\))\\)?}}}") + (when (looking-at "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\((\\([^\000]*?\\))\\)?}}}") (let ((begin (point)) (key (downcase (match-string-no-properties 1))) (value (match-string-no-properties 0)) (post-blank (progn (goto-char (match-end 0)) (skip-chars-forward " \t"))) (end (point)) - (args (let ((args (match-string-no-properties 3))) - (and args (org-macro-extract-arguments args))))) + (args (pcase (match-string-no-properties 3) + (`nil nil) + (a (org-macro-extract-arguments + (replace-regexp-in-string + "[ \t\r\n]+" " " (org-trim a))))))) (list 'macro (list :key key :value value @@ -3237,7 +3317,11 @@ Assume point is at the macro." (defun org-element-macro-interpreter (macro _) "Interpret MACRO object as Org syntax." - (org-element-property :value macro)) + (format "{{{%s%s}}}" + (org-element-property :key macro) + (pcase (org-element-property :args macro) + (`nil "") + (args (format "(%s)" (apply #'org-macro-escape-arguments args)))))) ;;;; Radio-target @@ -3815,7 +3899,8 @@ element it has to parse." ((org-at-heading-p) (org-element-inlinetask-parser limit raw-secondary-p)) ;; From there, elements can have affiliated keywords. - (t (let ((affiliated (org-element--collect-affiliated-keywords limit))) + (t (let ((affiliated (org-element--collect-affiliated-keywords + limit (memq granularity '(nil object))))) (cond ;; Jumping over affiliated keywords put point off-limits. ;; Parse them as regular keywords. @@ -3874,7 +3959,18 @@ element it has to parse." ((looking-at "%%(") (org-element-diary-sexp-parser limit affiliated)) ;; Table. - ((looking-at "[ \t]*\\(|\\|\\+\\(-+\\+\\)+[ \t]*$\\)") + ((or (looking-at "[ \t]*|") + ;; There is no strict definition of a table.el + ;; table. Try to prevent false positive while being + ;; quick. + (let ((rule-regexp "[ \t]*\\+\\(-+\\+\\)+[ \t]*$") + (next (line-beginning-position 2))) + (and (looking-at rule-regexp) + (save-excursion + (forward-line) + (re-search-forward "^[ \t]*\\($\\|[^|]\\)" limit t) + (and (> (line-beginning-position) next) + (org-match-line rule-regexp)))))) (org-element-table-parser limit affiliated)) ;; List. ((looking-at (org-item-re)) @@ -3890,7 +3986,7 @@ element it has to parse." ;; that element, and, in the meantime, collect information they give ;; into appropriate properties. Hence the following function. -(defun org-element--collect-affiliated-keywords (limit) +(defun org-element--collect-affiliated-keywords (limit parse) "Collect affiliated keywords from point down to LIMIT. Return a list whose CAR is the position at the first of them and @@ -3899,13 +3995,16 @@ beginning of the first line after them. As a special case, if element doesn't start at the beginning of the line (e.g., a paragraph starting an item), CAR is current -position of point and CDR is nil." +position of point and CDR is nil. + +When PARSE is non-nil, values from keywords belonging to +`org-element-parsed-keywords' are parsed as secondary strings." (if (not (bolp)) (list (point)) (let ((case-fold-search t) (origin (point)) ;; RESTRICT is the list of objects allowed in parsed - ;; keywords value. - (restrict (org-element-restriction 'keyword)) + ;; keywords value. If PARSE is nil, no object is allowed. + (restrict (and parse (org-element-restriction 'keyword))) output) (while (and (< (point) limit) (looking-at org-element--affiliated-re)) (let* ((raw-kwd (upcase (match-string 1))) @@ -3914,35 +4013,35 @@ position of point and CDR is nil." (kwd (or (cdr (assoc raw-kwd org-element-keyword-translation-alist)) raw-kwd)) + ;; PARSED? is non-nil when keyword should have its + ;; value parsed. + (parsed? (member kwd org-element-parsed-keywords)) ;; Find main value for any keyword. (value - (save-match-data - (org-trim - (buffer-substring-no-properties - (match-end 0) (line-end-position))))) - ;; PARSEDP is non-nil when keyword should have its - ;; value parsed. - (parsedp (member kwd org-element-parsed-keywords)) - ;; If KWD is a dual keyword, find its secondary - ;; value. Maybe parse it. - (dualp (member kwd org-element-dual-keywords)) + (let ((beg (match-end 0)) + (end (save-excursion + (end-of-line) + (skip-chars-backward " \t") + (point)))) + (if parsed? + (org-element--parse-objects beg end nil restrict) + (org-trim (buffer-substring-no-properties beg end))))) + ;; If KWD is a dual keyword, find its secondary value. + ;; Maybe parse it. + (dual? (member kwd org-element-dual-keywords)) (dual-value - (and dualp + (and dual? (let ((sec (match-string-no-properties 2))) - (if (or (not sec) (not parsedp)) sec + (cond + ((and sec parsed?) (save-match-data (org-element--parse-objects - (match-beginning 2) (match-end 2) nil restrict)))))) + (match-beginning 2) (match-end 2) nil restrict))) + (sec sec))))) ;; Attribute a property name to KWD. (kwd-sym (and kwd (intern (concat ":" (downcase kwd)))))) ;; Now set final shape for VALUE. - (when parsedp - (setq value - (org-element--parse-objects - (match-end 0) - (progn (end-of-line) (skip-chars-backward " \t") (point)) - nil restrict))) - (when dualp + (when dual? (setq value (and (or value dual-value) (cons value dual-value)))) (when (or (member kwd org-element-multiple-keywords) ;; Attributes can always appear on multiple lines. @@ -4046,7 +4145,10 @@ If STRING is the empty string or nil, return nil." (ignore-errors (if (symbolp v) (makunbound v) (set (make-local-variable (car v)) (cdr v))))) - (insert string) + ;; Transferring local variables may put the temporary buffer + ;; into a read-only state. Make sure we can insert STRING. + (let ((inhibit-read-only t)) (insert string)) + ;; Prevent "Buffer *temp* modified; kill anyway?". (restore-buffer-modified-p nil) (org-element--parse-objects (point-min) (point-max) nil restriction parent)))))) @@ -4532,8 +4634,9 @@ to interpret. Return Org syntax as a string." (and (eq type 'paragraph) (memq (org-element-type parent) '(footnote-definition item)) - (eq data - (car (org-element-contents parent))))))) + (eq data (car (org-element-contents parent))) + (eq (org-element-property :pre-blank parent) + 0))))) "")))))) (if (memq type '(org-data plain-text nil)) results ;; Build white spaces. If no `:post-blank' property @@ -4555,7 +4658,7 @@ If there is no affiliated keyword, return the empty string." (let (dual) (when (member key org-element-dual-keywords) (setq dual (cdr value) value (car value))) - (concat "#+" key + (concat "#+" (downcase key) (and dual (format "[%s]" (org-element-interpret-data dual))) ": " @@ -4950,7 +5053,6 @@ A and B are either integers or lists of integers, as returned by (defsubst org-element--cache-root () "Return root value in cache. This function assumes `org-element--cache' is a valid AVL tree." - ;; FIXME: Why use internal functions of avl-tree? (avl-tree--node-left (avl-tree--dummyroot org-element--cache))) @@ -4979,7 +5081,6 @@ the cache." (aref (car org-element--cache-sync-requests) 0))) (node (org-element--cache-root)) lower upper) - ;; FIXME: Why use internal functions of avl-tree? (while node (let* ((element (avl-tree--node-data node)) (begin (org-element-property :begin element))) @@ -5055,7 +5156,7 @@ Assume ELEMENT belongs to cache and that a cache is active." (setq org-element--cache-sync-timer (run-with-idle-timer (let ((idle (current-idle-time))) - (if idle (time-add idle org-element-cache-sync-break) + (if idle (org-time-add idle org-element-cache-sync-break) org-element-cache-sync-idle-time)) nil #'org-element--cache-sync @@ -5066,7 +5167,7 @@ Assume ELEMENT belongs to cache and that a cache is active." TIME-LIMIT is a time value or nil." (and time-limit (or (input-pending-p) - (time-less-p time-limit nil)))) + (org-time-less-p time-limit nil)))) (defsubst org-element--cache-shift-positions (element offset &optional props) "Shift ELEMENT properties relative to buffer positions by OFFSET. @@ -5120,7 +5221,8 @@ updated before current modification are actually submitted." (and next (aref next 0)) threshold (and (not threshold) - (time-add nil org-element-cache-sync-duration)) + (org-time-add nil + org-element-cache-sync-duration)) future-change) ;; Request processed. Merge current and next offsets and ;; transfer ending position. @@ -5460,7 +5562,7 @@ the process stopped before finding the expected result." (defconst org-element--cache-sensitive-re (concat - org-outline-regexp-bol "\\|" + "^\\*+ " "\\|" "\\\\end{[A-Za-z0-9*]+}[ \t]*$" "\\|" "^[ \t]*\\(?:" "#\\+\\(?:BEGIN[:_]\\|END\\(?:_\\|:?[ \t]*$\\)\\)" "\\|" @@ -5869,24 +5971,24 @@ Providing it allows for quicker computation." ;; Otherwise, return NEXT. (t (throw 'exit next))))))))))))) -(defun org-element-lineage (blob &optional types with-self) +(defun org-element-lineage (datum &optional types with-self) "List all ancestors of a given element or object. -BLOB is an object or element. +DATUM is an object or element. -When optional argument TYPES is a list of symbols, return the -first element or object in the lineage whose type belongs to that -list. +Return ancestors from the closest to the farthest. When optional +argument TYPES is a list of symbols, return the first element or +object in the lineage whose type belongs to that list instead. When optional argument WITH-SELF is non-nil, lineage includes -BLOB itself as the first element, and TYPES, if provided, also +DATUM itself as the first element, and TYPES, if provided, also apply to it. -When BLOB is obtained through `org-element-context' or +When DATUM is obtained through `org-element-context' or `org-element-at-point', only ancestors from its section can be -found. There is no such limitation when BLOB belongs to a full +found. There is no such limitation when DATUM belongs to a full parse tree." - (let ((up (if with-self blob (org-element-property :parent blob))) + (let ((up (if with-self datum (org-element-property :parent datum))) ancestors) (while (and up (not (memq (org-element-type up) types))) (unless types (push up ancestors)) @@ -5914,16 +6016,16 @@ end of ELEM-A." ;; ELEM-A position in such a situation. Note that the case of ;; a footnote definition is impossible: it cannot contain two ;; paragraphs in a row because it cannot contain a blank line. - (if (and specialp - (or (not (eq (org-element-type elem-B) 'paragraph)) - (/= (org-element-property :begin elem-B) - (org-element-property :contents-begin elem-B)))) - (error "Cannot swap elements")) + (when (and specialp + (or (not (eq (org-element-type elem-B) 'paragraph)) + (/= (org-element-property :begin elem-B) + (org-element-property :contents-begin elem-B)))) + (error "Cannot swap elements")) ;; In a special situation, ELEM-A will have no indentation. We'll ;; give it ELEM-B's (which will in, in turn, have no indentation). (let* ((ind-B (when specialp (goto-char (org-element-property :begin elem-B)) - (org-get-indentation))) + (current-indentation))) (beg-A (org-element-property :begin elem-A)) (end-A (save-excursion (goto-char (org-element-property :end elem-A)) diff --git a/lisp/org/org-entities.el b/lisp/org/org-entities.el index 66837f3eb0b..a5c05eaa21b 100644 --- a/lisp/org/org-entities.el +++ b/lisp/org/org-entities.el @@ -543,11 +543,11 @@ This first checks the user list, then the built-in list." (dolist (e org-entities) (pcase e (`(,name ,latex ,mathp ,html ,ascii ,latin ,utf8) - (if (equal ascii "|") (setq ascii "\\vert")) - (if (equal latin "|") (setq latin "\\vert")) - (if (equal utf8 "|") (setq utf8 "\\vert")) - (if (equal ascii "=>") (setq ascii "= >")) - (if (equal latin "=>") (setq latin "= >")) + (when (equal ascii "|") (setq ascii "\\vert")) + (when (equal latin "|") (setq latin "\\vert")) + (when (equal utf8 "|") (setq utf8 "\\vert")) + (when (equal ascii "=>") (setq ascii "= >")) + (when (equal latin "=>") (setq latin "= >")) (insert "|" name "|" (format "=%s=" latex) "|" (format (if mathp "$%s$" "$\\mbox{%s}$") latex) diff --git a/lisp/org/org-faces.el b/lisp/org/org-faces.el index ffd1c4494fc..a97d4dc4a45 100644 --- a/lisp/org/org-faces.el +++ b/lisp/org/org-faces.el @@ -311,7 +311,7 @@ determines if it is a foreground or a background color." (if (not value) (setq org-tags-special-faces-re nil) (setq org-tags-special-faces-re - (concat ":\\(" (mapconcat 'car value "\\|") "\\):")))) + (concat ":" (regexp-opt (mapcar #'car value) t) ":")))) (defface org-checkbox '((t :inherit bold)) "Face for checkboxes." @@ -395,8 +395,7 @@ follows a #+DATE:, #+AUTHOR: or #+EMAIL: keyword." (defface org-block '((t :inherit shadow)) "Face text in #+begin ... #+end blocks. -For source-blocks `org-src-block-faces' takes precedence. -See also `org-fontify-quote-and-verse-blocks'." +For source-blocks `org-src-block-faces' takes precedence." :group 'org-faces :version "26.1") @@ -414,11 +413,13 @@ See also `org-fontify-quote-and-verse-blocks'." :version "22.1") (defface org-quote '((t (:inherit org-block))) - "Face for #+BEGIN_QUOTE ... #+END_QUOTE blocks." + "Face for #+BEGIN_QUOTE ... #+END_QUOTE blocks. +Active when `org-fontify-quote-and-verse-blocks' is set." :group 'org-faces) (defface org-verse '((t (:inherit org-block))) - "Face for #+BEGIN_VERSE ... #+END_VERSE blocks." + "Face for #+BEGIN_VERSE ... #+END_VERSE blocks. +Active when `org-fontify-quote-and-verse-blocks' is set." :group 'org-faces) (defcustom org-fontify-quote-and-verse-blocks nil @@ -511,13 +512,18 @@ which days belong to the weekend." (((class color) (min-colors 8) (background light)) (:foreground "red")) (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t)) (t (:bold t))) - "Face for items scheduled previously, and not yet done." + "Face for items scheduled previously, and not yet done. +See also `org-agenda-deadline-faces'." :group 'org-faces) +(defface org-upcoming-distant-deadline '((t :inherit org-default)) + "Face for items scheduled previously, not done, and have a distant deadline. +See also `org-agenda-deadline-faces'.") + (defcustom org-agenda-deadline-faces '((1.0 . org-warning) (0.5 . org-upcoming-deadline) - (0.0 . default)) + (0.0 . org-upcoming-distant-deadline)) "Faces for showing deadlines in the agenda. This is a list of cons cells. The cdr of each cell is a face to be used, and it can also just be like \\='(:foreground \"yellow\"). @@ -553,10 +559,6 @@ month and 365.24 days for a year)." "Face for tag(s) in the mode-line when filtering the agenda." :group 'org-faces) -(defface org-agenda-filter-regexp '((t :inherit mode-line)) - "Face for regexp(s) in the mode-line when filtering the agenda." - :group 'org-faces) - (defface org-agenda-filter-category '((t :inherit mode-line)) "Face for categories in the mode-line when filtering the agenda." :group 'org-faces) @@ -565,6 +567,10 @@ month and 365.24 days for a year)." "Face for effort in the mode-line when filtering the agenda." :group 'org-faces) +(defface org-agenda-filter-regexp '((t :inherit mode-line)) + "Face for regexp(s) in the mode-line when filtering the agenda." + :group 'org-faces) + (defface org-time-grid ;Copied from `font-lock-variable-name-face' '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod")) (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod")) diff --git a/lisp/org/org-feed.el b/lisp/org/org-feed.el index b2dc4f309c4..f9f5fb051e8 100644 --- a/lisp/org/org-feed.el +++ b/lisp/org/org-feed.el @@ -407,14 +407,13 @@ it can be a list structured like an entry in `org-feed-alist'." ;; Write the new status ;; We do this only now, in case something goes wrong above, so ;; that would would end up with a status that does not reflect - ;; which items truely have been handled + ;; which items truly have been handled (org-feed-write-status inbox-pos drawer status) ;; Normalize the visibility of the inbox tree (goto-char inbox-pos) - (outline-hide-subtree) + (org-flag-subtree t) (org-show-children) - (org-cycle-hide-drawers 'children) ;; Hooks and messages (when org-feed-save-after-adding (save-buffer)) @@ -567,7 +566,7 @@ If that property is already present, nothing changes." (if (looking-at (concat "^\\([ \t]*\\)%" name "[ \t]*$")) (org-feed-make-indented-block - v (org-get-indentation)) + v (current-indentation)) v)))))))) (when replacement (insert diff --git a/lisp/org/org-footnote.el b/lisp/org/org-footnote.el index f8963184654..0fe382819de 100644 --- a/lisp/org/org-footnote.el +++ b/lisp/org/org-footnote.el @@ -47,18 +47,16 @@ (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)) -(declare-function org-in-regexp "org" (re &optional nlines visually)) (declare-function org-in-verbatim-emphasis "org" ()) (declare-function org-inside-LaTeX-fragment-p "org" ()) (declare-function org-inside-latex-macro-p "org" ()) (declare-function org-mark-ring-push "org" (&optional pos buffer)) (declare-function org-show-context "org" (&optional key)) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function outline-next-heading "outline") (defvar electric-indent-mode) (defvar org-blank-before-new-entry) ; defined in org.el -(defvar org-bracket-link-regexp) ; defined in org.el +(defvar org-link-bracket-re) ; defined in org.el (defvar org-complex-heading-regexp) ; defined in org.el (defvar org-odd-levels-only) ; defined in org.el (defvar org-outline-regexp) ; defined in org.el @@ -116,7 +114,8 @@ you will need to run the following command after the change: (org-element-cache-reset 'all))) :type '(choice (string :tag "Collect footnotes under heading") - (const :tag "Define footnotes locally" nil))) + (const :tag "Define footnotes locally" nil)) + :safe #'string-or-null-p) (defcustom org-footnote-define-inline nil "Non-nil means define footnotes inline, at reference location. @@ -124,7 +123,8 @@ When nil, footnotes will be defined in a special section near the end of the document. When t, the [fn:label:definition] notation will be used to define the footnote at the reference position." :group 'org-footnote - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defcustom org-footnote-auto-label t "Non-nil means define automatically new labels for footnotes. @@ -141,7 +141,8 @@ random Automatically generate a unique, random label." (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 a random label" random))) + (const :tag "Create a random label" random)) + :safe #'symbolp) (defcustom org-footnote-auto-adjust nil "Non-nil means automatically adjust footnotes after insert/delete. @@ -159,7 +160,8 @@ The main values of this variable can be set with in-buffer options: (const :tag "No adjustment" nil) (const :tag "Renumber" renumber) (const :tag "Sort" sort) - (const :tag "Renumber and Sort" t))) + (const :tag "Renumber and Sort" t)) + :safe #'symbolp) (defcustom org-footnote-fill-after-inline-note-extraction nil "Non-nil means fill paragraphs after extracting footnotes. @@ -167,7 +169,8 @@ When extracting inline footnotes, the lengths of lines can change a lot. When this option is set, paragraphs from which an inline footnote has been extracted will be filled again." :group 'org-footnote - :type 'boolean) + :type 'boolean + :safe #'booleanp) ;;;; Predicates @@ -186,76 +189,53 @@ extracted will be filled again." (org-in-block-p org-footnote-forbidden-blocks))))) (defun org-footnote-at-reference-p () - "Is the cursor at a footnote reference? - + "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 inlined." - (when (and (org-footnote-in-valid-context-p) - (or (looking-at org-footnote-re) - (org-in-regexp org-footnote-re) - (save-excursion (re-search-backward org-footnote-re nil t))) - (/= (match-beginning 0) (line-beginning-position))) - (let* ((beg (match-beginning 0)) - (label (match-string-no-properties 1)) - ;; Inline footnotes don't end at (match-end 0) as - ;; `org-footnote-re' stops just after the second colon. - ;; Find the real ending with `scan-sexps', so Org doesn't - ;; get fooled by unrelated closing square brackets. - (end (ignore-errors (scan-sexps beg 1)))) - ;; Point is really at a reference if it's located before true - ;; ending of the footnote. - (when (and end - (< (point) end) - ;; Verify match isn't a part of a link. - (not (save-excursion - (goto-char beg) - (let ((linkp - (save-match-data - (org-in-regexp org-bracket-link-regexp)))) - (and linkp (< (point) (cdr linkp)))))) - ;; Verify point doesn't belong to a LaTeX macro. - (not (org-inside-latex-macro-p))) - (list label beg end - ;; Definition: ensure this is an inline footnote first. - (and (match-end 2) - (org-trim - (buffer-substring-no-properties - (match-end 0) (1- end))))))))) +positions, and the definition, when inline." + (let ((reference (org-element-context))) + (when (eq 'footnote-reference (org-element-type reference)) + (let ((end (save-excursion + (goto-char (org-element-property :end reference)) + (skip-chars-backward " \t") + (point)))) + (when (< (point) end) + (list (org-element-property :label reference) + (org-element-property :begin reference) + end + (and (eq 'inline (org-element-property :type reference)) + (buffer-substring-no-properties + (org-element-property :contents-begin reference) + (org-element-property :contents-end + reference))))))))) (defun org-footnote-at-definition-p () - "Is point within a footnote definition? + "Non-nil if point is within a footnote definition. -This matches only pure definitions like [1] or [fn:name] at the +This matches only pure definitions like [fn:name] at the beginning of a line. It does not match references like \[fn:name:definition], where the footnote text is included and defined locally. -The return value will be nil if not at a footnote definition, and +The return value is nil if not at a footnote definition, and a list with label, start, end and definition of the footnote otherwise." - (when (save-excursion (beginning-of-line) (org-footnote-in-valid-context-p)) - (save-excursion - (end-of-line) - ;; Footnotes definitions are separated by new headlines, another - ;; footnote definition or 2 blank lines. - (let ((lim (save-excursion - (re-search-backward - (concat org-outline-regexp-bol - "\\|^\\([ \t]*\n\\)\\{2,\\}") nil t)))) - (when (re-search-backward org-footnote-definition-re lim t) - (let ((label (match-string-no-properties 1)) - (beg (match-beginning 0)) - (beg-def (match-end 0)) - (end (if (progn - (end-of-line) - (re-search-forward - (concat org-outline-regexp-bol "\\|" - org-footnote-definition-re "\\|" - "^\\([ \t]*\n\\)\\{2,\\}") nil 'move)) - (match-beginning 0) - (point)))) - (list label beg end - (org-trim (buffer-substring-no-properties beg-def end))))))))) + (pcase (org-element-lineage (org-element-at-point) '(footnote-definition) t) + (`nil nil) + (definition + (let* ((label (org-element-property :label definition)) + (begin (org-element-property :post-affiliated definition)) + (end (save-excursion + (goto-char (org-element-property :end definition)) + (skip-chars-backward " \r\t\n") + (line-beginning-position 2))) + (contents-begin (org-element-property :contents-begin definition)) + (contents-end (org-element-property :contents-end definition)) + (contents + (if (not contents-begin) "" + (org-trim + (buffer-substring-no-properties contents-begin + contents-end))))) + (list label begin end contents))))) ;;;; Internal functions @@ -313,23 +293,23 @@ otherwise." (defun org-footnote--clear-footnote-section () "Remove all footnote sections in buffer and create a new one. -New section is created at the end of the buffer, before any file -local variable definition. Leave point within the new section." +New section is created at the end of the buffer. Leave point +within the new section." (when org-footnote-section (goto-char (point-min)) - (let ((regexp - (format "^\\*+ +%s[ \t]*$" - (regexp-quote org-footnote-section)))) + (let ((regexp (format "^\\*+ +%s[ \t]*$" + (regexp-quote org-footnote-section)))) (while (re-search-forward regexp nil t) (delete-region (match-beginning 0) - (progn (org-end-of-subtree t t) - (if (not (eobp)) (point) - (org-footnote--goto-local-insertion-point) - (skip-chars-forward " \t\n") - (if (eobp) (point) (line-beginning-position))))))) + (org-end-of-subtree t t)))) (goto-char (point-max)) - (org-footnote--goto-local-insertion-point) + ;; Clean-up blank lines at the end of the buffer. + (skip-chars-backward " \r\t\n") + (unless (bobp) + (forward-line) + (when (eolp) (insert "\n"))) + (delete-region (point) (point-max)) (when (and (cdr (assq 'heading org-blank-before-new-entry)) (zerop (save-excursion (org-back-over-empty-lines)))) (insert "\n")) @@ -448,14 +428,8 @@ while collecting them." "Find insertion point for footnote, just before next outline heading. Assume insertion point is within currently accessible part of the buffer." (org-with-limited-levels (outline-next-heading)) - ;; Skip file local variables. See `modify-file-local-variable'. - (when (eobp) - (let ((case-fold-search t)) - (re-search-backward "^[ \t]*# +Local Variables:" - (max (- (point-max) 3000) (point-min)) - t))) (skip-chars-backward " \t\n") - (forward-line) + (unless (bobp) (forward-line)) (unless (bolp) (insert "\n"))) @@ -470,16 +444,15 @@ the buffer position bounding the search. Return value is a list like those provided by `org-footnote-at-reference-p'. If no footnote is found, return nil." - (save-excursion - (let* ((label-fmt (if label (format "\\[fn:%s[]:]" label) org-footnote-re))) - (catch 'exit - (while t - (unless (funcall (if backward #'re-search-backward #'re-search-forward) - label-fmt limit t) - (throw 'exit nil)) + (let ((label-regexp (if label (format "\\[fn:%s[]:]" label) org-footnote-re))) + (catch :exit + (save-excursion + (while (funcall (if backward #'re-search-backward #'re-search-forward) + label-regexp limit t) (unless backward (backward-char)) - (let ((ref (org-footnote-at-reference-p))) - (when ref (throw 'exit ref)))))))) + (pcase (org-footnote-at-reference-p) + (`nil nil) + (reference (throw :exit reference)))))))) (defun org-footnote-next-reference-or-definition (limit) "Move point to next footnote reference or definition. @@ -488,8 +461,10 @@ LIMIT is the buffer position bounding the search. Return value is a list like those provided by `org-footnote-at-reference-p' or `org-footnote-at-definition-p'. -If no footnote is found, return nil." - (let* (ref (origin (point))) +If no footnote is found, return nil. + +This function is meant to be used for fontification only." + (let ((origin (point))) (catch 'exit (while t (unless (re-search-forward org-footnote-re limit t) @@ -499,15 +474,56 @@ If no footnote is found, return nil." ;; the closing square bracket. (backward-char) (cond - ((setq ref (org-footnote-at-reference-p)) - (throw 'exit ref)) + ((and (/= (match-beginning 0) (line-beginning-position)) + (let* ((beg (match-beginning 0)) + (label (match-string-no-properties 1)) + ;; Inline footnotes don't end at (match-end 0) + ;; as `org-footnote-re' stops just after the + ;; second colon. Find the real ending with + ;; `scan-sexps', so Org doesn't get fooled by + ;; unrelated closing square brackets. + (end (ignore-errors (scan-sexps beg 1)))) + (and end + ;; Verify match isn't a part of a link. + (not (save-excursion + (goto-char beg) + (let ((linkp + (save-match-data + (org-in-regexp org-link-bracket-re)))) + (and linkp (< (point) (cdr linkp)))))) + ;; Verify point doesn't belong to a LaTeX macro. + (not (org-inside-latex-macro-p)) + (throw 'exit + (list label beg end + ;; Definition: ensure this is an + ;; inline footnote first. + (and (match-end 2) + (org-trim + (buffer-substring-no-properties + (match-end 0) (1- end)))))))))) ;; Definition: also grab the last square bracket, matched in ;; `org-footnote-re' for non-inline footnotes. - ((save-match-data (org-footnote-at-definition-p)) - (let ((end (match-end 0))) - (throw 'exit - (list nil (match-beginning 0) - (if (eq (char-before end) ?\]) end (1+ end))))))))))) + ((and (save-excursion + (beginning-of-line) + (save-match-data (org-footnote-in-valid-context-p))) + (save-excursion + (end-of-line) + ;; Footnotes definitions are separated by new + ;; headlines, another footnote definition or 2 blank + ;; lines. + (let ((end (match-end 0)) + (lim (save-excursion + (re-search-backward + (concat org-outline-regexp-bol + "\\|^\\([ \t]*\n\\)\\{2,\\}") + nil t)))) + (and (re-search-backward org-footnote-definition-re lim t) + (throw 'exit + (list nil + (match-beginning 0) + (if (eq (char-before end) ?\]) end + (1+ end))))))))) + (t nil)))))) (defun org-footnote-goto-definition (label &optional location) "Move point to the definition of the footnote LABEL. @@ -528,7 +544,7 @@ value if point was successfully moved." (user-error "Definition is outside narrowed part of buffer"))) (org-mark-ring-push) (goto-char def-start) - (looking-at (format "\\[fn:%s[]:] ?" (regexp-quote label))) + (looking-at (format "\\[fn:%s[]:]" (regexp-quote label))) (goto-char (match-end 0)) (org-show-context 'link-search) (when (derived-mode-p 'org-mode) @@ -540,21 +556,23 @@ value if point was successfully moved." (defun org-footnote-goto-previous-reference (label) "Find the first closest (to point) reference of footnote with label LABEL." (interactive "sLabel: ") - (org-mark-ring-push) - (let ((label (org-footnote-normalize-label label)) - ref) - (save-excursion - (setq ref (or (org-footnote-get-next-reference label t) - (org-footnote-get-next-reference label) - (save-restriction - (widen) - (or - (org-footnote-get-next-reference label t) - (org-footnote-get-next-reference label)))))) - (if (not ref) - (error "Cannot find reference of footnote %s" label) - (goto-char (nth 1 ref)) - (org-show-context 'link-search)))) + (let* ((label (org-footnote-normalize-label label)) + (reference + (save-excursion + (or (org-footnote-get-next-reference label t) + (org-footnote-get-next-reference label) + (and (buffer-narrowed-p) + (org-with-wide-buffer + (or (org-footnote-get-next-reference label t) + (org-footnote-get-next-reference label))))))) + (start (nth 1 reference))) + (cond ((not reference) + (user-error "Cannot find reference of footnote %S" label)) + ((or (> start (point-max)) (< start (point-min))) + (user-error "Reference is outside narrowed part of buffer"))) + (org-mark-ring-push) + (goto-char start) + (org-show-context 'link-search))) ;;;; Getters @@ -676,21 +694,22 @@ Return buffer position at the beginning of the definition. This function doesn't move point." (let ((label (org-footnote-normalize-label label)) electric-indent-mode) ; Prevent wrong indentation. - (org-with-wide-buffer - (cond - ((not org-footnote-section) (org-footnote--goto-local-insertion-point)) - ((save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^\\*+[ \t]+" (regexp-quote org-footnote-section) "[ \t]*$") - nil t)) - (goto-char (match-end 0)) - (forward-line) - (unless (bolp) (insert "\n"))) - (t (org-footnote--clear-footnote-section))) - (when (zerop (org-back-over-empty-lines)) (insert "\n")) - (insert "[fn:" label "] \n") - (line-beginning-position 0)))) + (org-preserve-local-variables + (org-with-wide-buffer + (cond + ((not org-footnote-section) (org-footnote--goto-local-insertion-point)) + ((save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "^\\*+[ \t]+" (regexp-quote org-footnote-section) "[ \t]*$") + nil t)) + (goto-char (match-end 0)) + (forward-line) + (unless (bolp) (insert "\n"))) + (t (org-footnote--clear-footnote-section))) + (when (zerop (org-back-over-empty-lines)) (insert "\n")) + (insert "[fn:" label "] \n") + (line-beginning-position 0))))) (defun org-footnote-delete-references (label) "Delete every reference to footnote LABEL. @@ -733,31 +752,32 @@ and all references of a footnote label. If LABEL is non-nil, delete that footnote instead." (catch 'done - (let* ((nref 0) (ndef 0) x - ;; 1. Determine LABEL of footnote at point. - (label (cond - ;; LABEL is provided as argument. - (label) - ;; Footnote reference at point. If the footnote is - ;; anonymous, delete it and exit instead. - ((setq x (org-footnote-at-reference-p)) - (or (car x) - (progn - (delete-region (nth 1 x) (nth 2 x)) - (message "Anonymous footnote removed") - (throw 'done t)))) - ;; Footnote definition at point. - ((setq x (org-footnote-at-definition-p)) - (car x)) - (t (error "Don't know which footnote to remove"))))) - ;; 2. Now that LABEL is non-nil, find every reference and every - ;; definition, and delete them. - (setq nref (org-footnote-delete-references label) - ndef (org-footnote-delete-definitions label)) - ;; 3. Verify consistency of footnotes and notify user. - (org-footnote-auto-adjust-maybe) - (message "%d definition(s) of and %d reference(s) of footnote %s removed" - ndef nref label)))) + (org-preserve-local-variables + (let* ((nref 0) (ndef 0) x + ;; 1. Determine LABEL of footnote at point. + (label (cond + ;; LABEL is provided as argument. + (label) + ;; Footnote reference at point. If the footnote is + ;; anonymous, delete it and exit instead. + ((setq x (org-footnote-at-reference-p)) + (or (car x) + (progn + (delete-region (nth 1 x) (nth 2 x)) + (message "Anonymous footnote removed") + (throw 'done t)))) + ;; Footnote definition at point. + ((setq x (org-footnote-at-definition-p)) + (car x)) + (t (error "Don't know which footnote to remove"))))) + ;; 2. Now that LABEL is non-nil, find every reference and every + ;; definition, and delete them. + (setq nref (org-footnote-delete-references label) + ndef (org-footnote-delete-definitions label)) + ;; 3. Verify consistency of footnotes and notify user. + (org-footnote-auto-adjust-maybe) + (message "%d definition(s) of and %d reference(s) of footnote %s removed" + ndef nref label))))) ;;;; Sorting, Renumbering, Normalizing @@ -765,28 +785,25 @@ If LABEL is non-nil, delete that footnote instead." (defun org-footnote-renumber-fn:N () "Order numbered footnotes into a sequence in the document." (interactive) - (let ((references (org-footnote--collect-references))) - (unwind-protect - (let* ((c 0) - (references (cl-remove-if-not - (lambda (r) (string-match-p "\\`[0-9]+\\'" (car r))) - references)) - (alist (mapcar (lambda (l) (cons l (number-to-string (cl-incf c)))) - (delete-dups (mapcar #'car references))))) - (org-with-wide-buffer - ;; Re-number references. - (dolist (ref references) - (goto-char (nth 1 ref)) - (org-footnote--set-label (cdr (assoc (nth 0 ref) alist)))) - ;; Re-number definitions. - (goto-char (point-min)) - (while (re-search-forward "^\\[fn:\\([0-9]+\\)\\]" nil t) - (replace-match (or (cdr (assoc (match-string 1) alist)) - ;; Un-referenced definitions get - ;; higher numbers. - (number-to-string (cl-incf c))) - nil nil nil 1)))) - (dolist (r references) (set-marker (nth 1 r) nil))))) + (let* ((c 0) + (references (cl-remove-if-not + (lambda (r) (string-match-p "\\`[0-9]+\\'" (car r))) + (org-footnote--collect-references))) + (alist (mapcar (lambda (l) (cons l (number-to-string (cl-incf c)))) + (delete-dups (mapcar #'car references))))) + (org-with-wide-buffer + ;; Re-number references. + (dolist (ref references) + (goto-char (nth 1 ref)) + (org-footnote--set-label (cdr (assoc (nth 0 ref) alist)))) + ;; Re-number definitions. + (goto-char (point-min)) + (while (re-search-forward "^\\[fn:\\([0-9]+\\)\\]" nil t) + (replace-match (or (cdr (assoc (match-string 1) alist)) + ;; Un-referenced definitions get higher + ;; numbers. + (number-to-string (cl-incf c))) + nil nil nil 1))))) (defun org-footnote-sort () "Rearrange footnote definitions in the current buffer. @@ -795,129 +812,121 @@ references. Also relocate definitions at the end of their relative section or within a single footnote section, according to `org-footnote-section'. Inline definitions are ignored." (let ((references (org-footnote--collect-references))) - (unwind-protect - (let ((definitions (org-footnote--collect-definitions 'delete))) - (org-with-wide-buffer - (org-footnote--clear-footnote-section) - ;; Insert footnote definitions at the appropriate location, - ;; separated by a blank line. Each definition is inserted - ;; only once throughout the buffer. - (let (inserted) - (dolist (cell references) - (let ((label (car cell)) - (nested (not (nth 2 cell))) - (inline (nth 3 cell))) - (unless (or (member label inserted) inline) - (push label inserted) - (unless (or org-footnote-section nested) - ;; If `org-footnote-section' is non-nil, or - ;; reference is nested, point is already at the - ;; correct position. Otherwise, move at the - ;; appropriate location within the section - ;; containing the reference. - (goto-char (nth 1 cell)) - (org-footnote--goto-local-insertion-point)) - (insert "\n" - (or (cdr (assoc label definitions)) - (format "[fn:%s] DEFINITION NOT FOUND." label)) - "\n")))) - ;; Insert un-referenced footnote definitions at the end. - (let ((unreferenced - (cl-remove-if (lambda (d) (member (car d) inserted)) - definitions))) - (dolist (d unreferenced) (insert "\n" (cdr d) "\n")))))) - ;; Clear dangling markers in the buffer. - (dolist (r references) (set-marker (nth 1 r) nil))))) + (org-preserve-local-variables + (let ((definitions (org-footnote--collect-definitions 'delete))) + (org-with-wide-buffer + (org-footnote--clear-footnote-section) + ;; Insert footnote definitions at the appropriate location, + ;; separated by a blank line. Each definition is inserted + ;; only once throughout the buffer. + (let (inserted) + (dolist (cell references) + (let ((label (car cell)) + (nested (not (nth 2 cell))) + (inline (nth 3 cell))) + (unless (or (member label inserted) inline) + (push label inserted) + (unless (or org-footnote-section nested) + ;; If `org-footnote-section' is non-nil, or + ;; reference is nested, point is already at the + ;; correct position. Otherwise, move at the + ;; appropriate location within the section + ;; containing the reference. + (goto-char (nth 1 cell)) + (org-footnote--goto-local-insertion-point)) + (insert "\n" + (or (cdr (assoc label definitions)) + (format "[fn:%s] DEFINITION NOT FOUND." label)) + "\n")))) + ;; Insert un-referenced footnote definitions at the end. + (pcase-dolist (`(,label . ,definition) definitions) + (unless (member label inserted) + (insert "\n" definition "\n"))))))))) (defun org-footnote-normalize () "Turn every footnote in buffer into a numbered one." (interactive) - (let ((references (org-footnote--collect-references 'anonymous))) - (unwind-protect - (let ((n 0) - (translations nil) - (definitions nil)) - (org-with-wide-buffer - ;; Update label for reference. We need to do this before - ;; clearing definitions in order to rename nested footnotes - ;; before they are deleted. - (dolist (cell references) - (let* ((label (car cell)) - (anonymous (not label)) - (new - (cond - ;; In order to differentiate anonymous - ;; references from regular ones, set their - ;; labels to integers, not strings. - (anonymous (setcar cell (cl-incf n))) - ((cdr (assoc label translations))) - (t (let ((l (number-to-string (cl-incf n)))) - (push (cons label l) translations) - l))))) - (goto-char (nth 1 cell)) ; Move to reference's start. - (org-footnote--set-label - (if anonymous (number-to-string new) new)) - (let ((size (nth 3 cell))) - ;; Transform inline footnotes into regular references - ;; and retain their definition for later insertion as - ;; a regular footnote definition. - (when size - (let ((def (concat - (format "[fn:%s] " new) - (org-trim - (substring - (delete-and-extract-region - (point) (+ (point) size 1)) - 1))))) - (push (cons (if anonymous new label) def) definitions) - (when org-footnote-fill-after-inline-note-extraction - (org-fill-paragraph))))))) - ;; Collect definitions. Update labels according to ALIST. - (let ((definitions - (nconc definitions - (org-footnote--collect-definitions 'delete))) - (inserted)) - (org-footnote--clear-footnote-section) - (dolist (cell references) - (let* ((label (car cell)) - (anonymous (integerp label)) - (pos (nth 1 cell))) - ;; Move to appropriate location, if required. When - ;; there is a footnote section or reference is - ;; nested, point is already at the expected location. - (unless (or org-footnote-section (not (nth 2 cell))) - (goto-char pos) - (org-footnote--goto-local-insertion-point)) - ;; Insert new definition once label is updated. - (unless (member label inserted) - (push label inserted) - (let ((stored (cdr (assoc label definitions))) - ;; Anonymous footnotes' label is already - ;; up-to-date. - (new (if anonymous label - (cdr (assoc label translations))))) - (insert "\n" - (cond - ((not stored) - (format "[fn:%s] DEFINITION NOT FOUND." new)) - (anonymous stored) - (t - (replace-regexp-in-string - "\\`\\[fn:\\(.*?\\)\\]" new stored nil nil 1))) - "\n"))))) - ;; Insert un-referenced footnote definitions at the end. - (let ((unreferenced - (cl-remove-if (lambda (d) (member (car d) inserted)) - definitions))) - (dolist (d unreferenced) - (insert "\n" - (replace-regexp-in-string - org-footnote-definition-re - (format "[fn:%d]" (cl-incf n)) - (cdr d)) - "\n")))))) - ;; Clear dangling markers. - (dolist (r references) (set-marker (nth 1 r) nil))))) + (org-preserve-local-variables + (let ((n 0) + (translations nil) + (definitions nil) + (references (org-footnote--collect-references 'anonymous))) + (org-with-wide-buffer + ;; Update label for reference. We need to do this before + ;; clearing definitions in order to rename nested footnotes + ;; before they are deleted. + (dolist (cell references) + (let* ((label (car cell)) + (anonymous (not label)) + (new + (cond + ;; In order to differentiate anonymous references + ;; from regular ones, set their labels to integers, + ;; not strings. + (anonymous (setcar cell (cl-incf n))) + ((cdr (assoc label translations))) + (t (let ((l (number-to-string (cl-incf n)))) + (push (cons label l) translations) + l))))) + (goto-char (nth 1 cell)) ; Move to reference's start. + (org-footnote--set-label + (if anonymous (number-to-string new) new)) + (let ((size (nth 3 cell))) + ;; Transform inline footnotes into regular references and + ;; retain their definition for later insertion as + ;; a regular footnote definition. + (when size + (let ((def (concat + (format "[fn:%s] " new) + (org-trim + (substring + (delete-and-extract-region + (point) (+ (point) size 1)) + 1))))) + (push (cons (if anonymous new label) def) definitions) + (when org-footnote-fill-after-inline-note-extraction + (org-fill-paragraph))))))) + ;; Collect definitions. Update labels according to ALIST. + (let ((definitions + (nconc definitions + (org-footnote--collect-definitions 'delete))) + (inserted)) + (org-footnote--clear-footnote-section) + (dolist (cell references) + (let* ((label (car cell)) + (anonymous (integerp label)) + (pos (nth 1 cell))) + ;; Move to appropriate location, if required. When there + ;; is a footnote section or reference is nested, point is + ;; already at the expected location. + (unless (or org-footnote-section (not (nth 2 cell))) + (goto-char pos) + (org-footnote--goto-local-insertion-point)) + ;; Insert new definition once label is updated. + (unless (member label inserted) + (push label inserted) + (let ((stored (cdr (assoc label definitions))) + ;; Anonymous footnotes' label is already + ;; up-to-date. + (new (if anonymous label + (cdr (assoc label translations))))) + (insert "\n" + (cond + ((not stored) + (format "[fn:%s] DEFINITION NOT FOUND." new)) + (anonymous stored) + (t + (replace-regexp-in-string + "\\`\\[fn:\\(.*?\\)\\]" new stored nil nil 1))) + "\n"))))) + ;; Insert un-referenced footnote definitions at the end. + (pcase-dolist (`(,label . ,definition) definitions) + (unless (member label inserted) + (insert "\n" + (replace-regexp-in-string org-footnote-definition-re + (format "[fn:%d]" (cl-incf n)) + definition) + "\n")))))))) (defun org-footnote-auto-adjust-maybe () "Renumber and/or sort footnotes according to user settings." diff --git a/lisp/org/org-goto.el b/lisp/org/org-goto.el new file mode 100644 index 00000000000..5ce9b8cb65a --- /dev/null +++ b/lisp/org/org-goto.el @@ -0,0 +1,312 @@ +;;; org-goto.el --- Fast navigation in an Org buffer -*- lexical-binding: t; -*- + +;; Copyright (C) 2012-2019 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'org-macs) +(require 'org-compat) + +(declare-function org-at-heading-p "org" (&optional ignored)) +(declare-function org-beginning-of-line "org" (&optional n)) +(declare-function org-defkey "org" (keymap key def)) +(declare-function org-mark-ring-push "org" (&optional pos buffer)) +(declare-function org-overview "org" ()) +(declare-function org-refile-check-position "org" (refile-pointer)) +(declare-function org-refile-get-location "org" (&optional prompt default-buffer new-nodes)) +(declare-function org-show-context "org" (&optional key)) +(declare-function org-show-set-visibility "org" (detail)) + +(defvar org-complex-heading-regexp) +(defvar org-startup-align-all-tables) +(defvar org-startup-folded) +(defvar org-startup-truncated) +(defvar org-special-ctrl-a/e) +(defvar org-refile-target-verify-function) +(defvar org-refile-use-outline-path) +(defvar org-refile-targets) + +(defvar org-goto-exit-command nil) +(defvar org-goto-map nil) +(defvar org-goto-marker nil) +(defvar org-goto-selected-point nil) +(defvar org-goto-start-pos nil) +(defvar org-goto-window-configuration nil) + +(defconst org-goto-local-auto-isearch-map (make-sparse-keymap)) +(set-keymap-parent org-goto-local-auto-isearch-map isearch-mode-map) + +(defconst org-goto-help + "Browse buffer copy, to find location or copy text.%s +RET=jump to location C-g=quit and return to previous location +\[Up]/[Down]=next/prev headline TAB=cycle visibility [/] org-occur") + + + +;;; Customization + +(defgroup org-goto nil + "Options concerning Org Goto navigation interface." + :tag "Org Goto" + :group 'org) + +(defcustom org-goto-interface 'outline + "The default interface to be used for `org-goto'. + +Allowed values are: + +`outline' + + The interface shows an outline of the relevant file and the + correct heading is found by moving through the outline or by + searching with incremental search. + +`outline-path-completion' + + Headlines in the current buffer are offered via completion. + This is the interface also used by the refile command." + :group 'org-goto + :type '(choice + (const :tag "Outline" outline) + (const :tag "Outline-path-completion" outline-path-completion))) + +(defcustom org-goto-max-level 5 + "Maximum target level when running `org-goto' with refile interface." + :group 'org-goto + :type 'integer) + +(defcustom org-goto-auto-isearch t + "Non-nil means typing characters in `org-goto' starts incremental search. +When nil, you can use these keybindings to navigate the buffer: + + q Quit the Org Goto interface + n Go to the next visible heading + p Go to the previous visible heading + f Go one heading forward on same level + b Go one heading backward on same level + u Go one heading up" + :group 'org-goto + :type 'boolean) + + + +;;; Internal functions + +(defun org-goto--set-map () + "Set the keymap `org-goto'." + (setq org-goto-map + (let ((map (make-sparse-keymap))) + (let ((cmds '(isearch-forward isearch-backward kill-ring-save set-mark-command + mouse-drag-region universal-argument org-occur))) + (dolist (cmd cmds) + (substitute-key-definition cmd cmd map global-map))) + (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) + (org-defkey map [(right)] 'org-goto-right) + (org-defkey map [(control ?g)] 'org-goto-quit) + (org-defkey map "\C-i" 'org-cycle) + (org-defkey map [(tab)] 'org-cycle) + (org-defkey map [(down)] 'outline-next-visible-heading) + (org-defkey map [(up)] 'outline-previous-visible-heading) + (if org-goto-auto-isearch + (if (fboundp 'define-key-after) + (define-key-after map [t] 'org-goto-local-auto-isearch) + nil) + (org-defkey map "q" 'org-goto-quit) + (org-defkey map "n" 'outline-next-visible-heading) + (org-defkey map "p" 'outline-previous-visible-heading) + (org-defkey map "f" 'outline-forward-same-level) + (org-defkey map "b" 'outline-backward-same-level) + (org-defkey map "u" 'outline-up-heading)) + (org-defkey map "/" 'org-occur) + (org-defkey map "\C-c\C-n" 'outline-next-visible-heading) + (org-defkey map "\C-c\C-p" 'outline-previous-visible-heading) + (org-defkey map "\C-c\C-f" 'outline-forward-same-level) + (org-defkey map "\C-c\C-b" 'outline-backward-same-level) + (org-defkey map "\C-c\C-u" 'outline-up-heading) + map))) + +;; `isearch-other-control-char' was removed in Emacs 24.4. +(if (fboundp 'isearch-other-control-char) + (progn + (define-key org-goto-local-auto-isearch-map "\C-i" 'isearch-other-control-char) + (define-key org-goto-local-auto-isearch-map "\C-m" 'isearch-other-control-char)) + (define-key org-goto-local-auto-isearch-map "\C-i" nil) + (define-key org-goto-local-auto-isearch-map "\C-m" nil) + (define-key org-goto-local-auto-isearch-map [return] nil)) + +(defun org-goto--local-search-headings (string bound noerror) + "Search and make sure that any matches are in headlines." + (catch 'return + (while (if isearch-forward + (search-forward string bound noerror) + (search-backward string bound noerror)) + (when (save-match-data + (and (save-excursion + (beginning-of-line) + (looking-at org-complex-heading-regexp)) + (or (not (match-beginning 5)) + (< (point) (match-beginning 5))))) + (throw 'return (point)))))) + +(defun org-goto-local-auto-isearch () + "Start isearch." + (interactive) + (let ((keys (this-command-keys))) + (when (eq (lookup-key isearch-mode-map keys) 'isearch-printing-char) + (isearch-mode t) + (isearch-process-search-char (string-to-char keys)) + (org-font-lock-ensure)))) + +(defun org-goto-ret (&optional _arg) + "Finish `org-goto' by going to the new location." + (interactive "P") + (setq org-goto-selected-point (point)) + (setq org-goto-exit-command 'return) + (throw 'exit nil)) + +(defun org-goto-left () + "Finish `org-goto' by going to the new location." + (interactive) + (if (org-at-heading-p) + (progn + (beginning-of-line 1) + (setq org-goto-selected-point (point) + org-goto-exit-command 'left) + (throw 'exit nil)) + (user-error "Not on a heading"))) + +(defun org-goto-right () + "Finish `org-goto' by going to the new location." + (interactive) + (if (org-at-heading-p) + (progn + (setq org-goto-selected-point (point) + org-goto-exit-command 'right) + (throw 'exit nil)) + (user-error "Not on a heading"))) + +(defun org-goto-quit () + "Finish `org-goto' without cursor motion." + (interactive) + (setq org-goto-selected-point nil) + (setq org-goto-exit-command 'quit) + (throw 'exit nil)) + + + +;;; Public API + +;;;###autoload +(defun org-goto-location (&optional _buf help) + "Let the user select a location in current buffer. +This function uses a recursive edit. It returns the selected +position or nil." + (org-no-popups + (let ((isearch-mode-map org-goto-local-auto-isearch-map) + (isearch-hide-immediately nil) + (isearch-search-fun-function + (lambda () #'org-goto--local-search-headings)) + (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 + (make-indirect-buffer (current-buffer) "*org-goto*") + (error (make-indirect-buffer (current-buffer) "*org-goto*")))) + (let (temp-buffer-show-function temp-buffer-show-hook) + (with-output-to-temp-buffer "*Org Help*" + (princ (format help (if org-goto-auto-isearch + " Just type for auto-isearch." + " n/p/f/b/u to navigate, q to quit."))))) + (org-fit-window-to-buffer (get-buffer-window "*Org Help*")) + (setq buffer-read-only nil) + (let ((org-startup-truncated t) + (org-startup-folded nil) + (org-startup-align-all-tables nil)) + (org-mode) + (org-overview)) + (setq buffer-read-only t) + (if (and (boundp 'org-goto-start-pos) + (integer-or-marker-p org-goto-start-pos)) + (progn (goto-char org-goto-start-pos) + (when (org-invisible-p) + (org-show-set-visibility 'lineage))) + (goto-char (point-min))) + (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*") + (cons org-goto-selected-point org-goto-exit-command)))) + +;;;###autoload +(defun org-goto (&optional alternative-interface) + "Look up a different location in the current file, keeping current visibility. + +When you want look-up or go to a different location in a +document, the fastest way is often to fold the entire buffer and +then dive into the tree. This method has the disadvantage, that +the previous location will be folded, which may not be what you +want. + +This command works around this by showing a copy of the current +buffer in an indirect buffer, in overview mode. You can dive +into the tree in that copy, use org-occur and incremental search +to find a location. When pressing RET or `Q', the command +returns to the original buffer in which the visibility is still +unchanged. After RET it will also jump to the location selected +in the indirect buffer and expose the headline hierarchy above. + +With a prefix argument, use the alternative interface: e.g., if +`org-goto-interface' is `outline' use `outline-path-completion'." + (interactive "P") + (org-goto--set-map) + (let* ((org-refile-targets `((nil . (:maxlevel . ,org-goto-max-level)))) + (org-refile-use-outline-path t) + (org-refile-target-verify-function nil) + (interface + (if (not alternative-interface) + org-goto-interface + (if (eq org-goto-interface 'outline) + 'outline-path-completion + 'outline))) + (org-goto-start-pos (point)) + (selected-point + (if (eq interface 'outline) (car (org-goto-location)) + (let ((pa (org-refile-get-location "Goto"))) + (org-refile-check-position pa) + (nth 3 pa))))) + (if selected-point + (progn + (org-mark-ring-push org-goto-start-pos) + (goto-char selected-point) + (when (or (org-invisible-p) (org-invisible-p2)) + (org-show-context 'org-goto))) + (message "Quit")))) + +(provide 'org-goto) + +;;; org-goto.el ends here diff --git a/lisp/org/org-habit.el b/lisp/org/org-habit.el index 6234d0251e9..22f2e47b4e1 100644 --- a/lisp/org/org-habit.el +++ b/lisp/org/org-habit.el @@ -89,6 +89,21 @@ It will be green even if it was done after the deadline." :group 'org-habit :type 'boolean) +(defcustom org-habit-scheduled-past-days nil + "Value to use instead of `org-scheduled-past-days', for habits only. + +If nil, `org-scheduled-past-days' is used. + +Setting this to say 10000 is a way to make habits always show up +as a reminder, even if you set `org-scheduled-past-days' to a +small value because you regard scheduled items as a way of +\"turning on\" TODO items on a particular date, rather than as a +means of creating calendar-based reminders." + :group 'org-habit + :type '(choice integer (const nil)) + :package-version '(Org . "9.3") + :safe (lambda (v) (or (integerp v) (null v)))) + (defface org-habit-clear-face '((((background light)) (:background "#8270f9")) (((background dark)) (:background "blue"))) @@ -373,31 +388,30 @@ current time." (throw :exit s)))))))))) donep))) markedp face) - (if donep - (let ((done-time (time-add - starting - (days-to-time - (- start (time-to-days starting)))))) - - (aset graph index org-habit-completed-glyph) - (setq markedp t) - (put-text-property - index (1+ index) 'help-echo - (format-time-string (org-time-stamp-format) done-time) graph) - (while (and done-dates - (= start (car done-dates))) - (setq last-done-date (car done-dates) - done-dates (cdr done-dates)))) - (if todayp - (aset graph index org-habit-today-glyph))) + (cond + (donep + (aset graph index org-habit-completed-glyph) + (setq markedp t) + (while (and done-dates (= start (car done-dates))) + (setq last-done-date (car done-dates)) + (setq done-dates (cdr done-dates)))) + (todayp + (aset graph index org-habit-today-glyph))) (setq face (if (or in-the-past-p todayp) (car faces) (cdr faces))) - (if (and in-the-past-p - (not (eq face 'org-habit-overdue-face)) - (not markedp)) - (setq face (cdr faces))) - (put-text-property index (1+ index) 'face face graph)) + (when (and in-the-past-p + (not (eq face 'org-habit-overdue-face)) + (not markedp)) + (setq face (cdr faces))) + (put-text-property index (1+ index) 'face face graph) + (put-text-property index (1+ index) + 'help-echo + (concat (format-time-string + (org-time-stamp-format) + (time-add starting (days-to-time (- start (time-to-days starting))))) + (if donep " DONE" "")) + graph)) (setq start (1+ start) index (1+ index))) graph)) @@ -406,7 +420,8 @@ current time." "Insert consistency graph for any habitual tasks." (let ((inhibit-read-only t) (buffer-invisibility-spec '(org-link)) - (moment (time-since (* 3600 org-extend-today-until)))) + (moment (org-time-subtract nil + (* 3600 org-extend-today-until)))) (save-excursion (goto-char (if line (point-at-bol) (point-min))) (while (not (eobp)) @@ -421,7 +436,7 @@ current time." habit (time-subtract moment (days-to-time org-habit-preceding-days)) moment - (time-add moment (days-to-time org-habit-following-days)))))) + (time-add moment (days-to-time org-habit-following-days)))))) (forward-line))))) (defun org-habit-toggle-habits () @@ -434,7 +449,18 @@ current time." (message "Habits turned %s" (if org-habit-show-habits "on" "off"))) -(org-defkey org-agenda-mode-map "K" 'org-habit-toggle-habits) +(defun org-habit-toggle-display-in-agenda (arg) + "Toggle display of habits in agenda. +With ARG toggle display of all vs. undone scheduled habits. +See `org-habit-show-all-today'." + (interactive "P") + (if (not arg) + (org-habit-toggle-habits) + (org-agenda-check-type t 'agenda) + (setq org-habit-show-all-today (not org-habit-show-all-today)) + (when org-habit-show-habits (org-agenda-redo)))) + +(org-defkey org-agenda-mode-map "K" 'org-habit-toggle-display-in-agenda) (provide 'org-habit) diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index 7f7faaae8e8..653baf9b73d 100644 --- a/lisp/org/org-id.el +++ b/lisp/org/org-id.el @@ -71,8 +71,11 @@ ;;; Code: (require 'org) +(require 'ol) (declare-function message-make-fqdn "message" ()) +(declare-function org-goto-location "org-goto" (&optional _buf help)) +(declare-function org-link-set-parameters "ol" (type &rest rest)) ;;; Customization @@ -139,11 +142,15 @@ org Org's own internal method, using an encoding of the current time to uuid Create random (version 4) UUIDs. If the program defined in `org-id-uuid-program' is available it is used to create the ID. - Otherwise an internal functions is used." + Otherwise an internal functions is used. + +ts Create ID's based on ISO8601 timestamps (without separators + and without timezone, local time). Precision down to seconds." :group 'org-id :type '(choice (const :tag "Org's internal method" org) - (const :tag "external: uuidgen" uuid))) + (const :tag "external: uuidgen" uuid) + (const :tag "ISO8601 timestamp" ts))) (defcustom org-id-prefix nil "The prefix for IDs. @@ -160,7 +167,7 @@ to have no space characters in them." "Non-nil means add the domain name to new IDs. This ensures global uniqueness of IDs, and is also suggested by the relevant RFCs. This is relevant only if `org-id-method' is -`org'. When uuidgen is used, the domain will never be added. +`org' or `ts'. When uuidgen is used, the domain will never be added. The default is to not use this because we have no really good way to get the true domain, and Org entries will normally not be shared with enough @@ -188,6 +195,22 @@ This variable is only relevant when `org-id-track-globally' is set." :group 'org-id :type 'file) +(defcustom org-id-locations-file-relative nil + "Determines if org-id-locations should be stored as relative links. +Non-nil means that links to locations are stored as links +relative to the location of where `org-id-locations-file' is +stored. + +Nil means to store absolute paths to files. + +This customization is useful when folders are shared across +systems but mounted at different roots. Relative path to +`org-id-locations-file' still has to be maintained across +systems." + :group 'org-id + :type 'boolean + :package-version '(Org . "9.3")) + (defvar org-id-locations nil "List of files with IDs in those files.") @@ -275,9 +298,9 @@ If necessary, the ID is created." ;;;###autoload (defun org-id-get-with-outline-drilling () "Use an outline-cycling interface to retrieve the ID of an entry. -This only finds entries in the current buffer, using `org-get-location'. +This only finds entries in the current buffer, using `org-goto-location'. It returns the ID of the entry. If necessary, the ID is created." - (let* ((spos (org-get-location (current-buffer) org-goto-help)) + (let* ((spos (org-goto-location)) (pom (and spos (move-marker (make-marker) (car spos))))) (prog1 (org-id-get pom 'create) (move-marker pom nil)))) @@ -349,6 +372,13 @@ So a typical ID could look like \"Org:4nd91V40HI\"." (require 'message) (concat "@" (message-make-fqdn)))))) (setq unique (concat etime postfix)))) + ((eq org-id-method 'ts) + (let ((ts (format-time-string "%Y%m%dT%H%M%S.%6N")) + (postfix (if org-id-include-domain + (progn + (require 'message) + (concat "@" (message-make-fqdn)))))) + (setq unique (concat ts postfix)))) (t (error "Invalid `org-id-method'"))) (concat prefix unique))) @@ -356,7 +386,7 @@ So a typical ID could look like \"Org:4nd91V40HI\"." "Return string with random (version 4) UUID." (let ((rnd (md5 (format "%s%s%s%s%s%s%s" (random) - (time-convert nil 'list) + (org-time-convert-to-list nil) (user-uid) (emacs-pid) (user-full-name) @@ -418,7 +448,7 @@ using `org-id-decode'." ;; FIXME: If TIME represents N seconds after the epoch, then ;; this encoding assumes 0 <= N < 110075314176 = (* (expt 36 4) 65536), ;; i.e., that TIME is from 1970-01-01 00:00:00 to 5458-02-23 20:09:36 UTC. - (setq time (time-convert time 'list)) + (setq time (org-time-convert-to-list nil)) (concat (org-id-int-to-b36 (nth 0 time) 4) (org-id-int-to-b36 (nth 1 time) 4) (org-id-int-to-b36 (nth 2 time) 4))) @@ -446,81 +476,56 @@ and TIME is a Lisp time value (HI LO USEC)." Store the relation between files and corresponding IDs. This will scan all agenda files, all associated archives, and all files currently mentioned in `org-id-locations'. -When FILES is given, scan these files instead." +When FILES is given, scan also these files." (interactive) (if (not org-id-track-globally) (error "Please turn on `org-id-track-globally' if you want to track IDs") - (let* ((org-id-search-archives - (or org-id-search-archives - (and (symbolp org-id-extra-files) - (symbol-value org-id-extra-files) - (member 'agenda-archives org-id-extra-files)))) - (files - (or files - (append - ;; Agenda files and all associated archives - (org-agenda-files t org-id-search-archives) - ;; Explicit extra files - (if (symbolp org-id-extra-files) - (symbol-value org-id-extra-files) - org-id-extra-files) - ;; Files associated with live Org buffers - (delq nil - (mapcar (lambda (b) - (with-current-buffer b - (and (derived-mode-p 'org-mode) (buffer-file-name)))) - (buffer-list))) - ;; All files known to have IDs - org-id-files))) - org-agenda-new-buffers - file nfiles tfile ids reg found id seen (ndup 0)) - (when (member 'agenda-archives files) - (setq files (delq 'agenda-archives (copy-sequence files)))) - (setq nfiles (length files)) - (while (setq file (pop files)) - (unless silent - (message "Finding ID locations (%d/%d files): %s" - (- nfiles (length files)) nfiles file)) - (setq tfile (file-truename file)) - (when (and (file-exists-p file) (not (member tfile seen))) - (push tfile seen) - (setq ids nil) - (with-current-buffer (org-get-agenda-file-buffer file) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward "^[ \t]*:ID:[ \t]+\\(\\S-+\\)[ \t]*$" - nil t) - (setq id (match-string-no-properties 1)) - (if (member id found) - (progn - (message "Duplicate ID \"%s\", also in file %s" - id (or (car (delq - nil - (mapcar - (lambda (x) - (if (member id (cdr x)) - (car x))) - reg))) - (buffer-file-name))) - (when (= ndup 0) - (ding) - (sit-for 2)) - (setq ndup (1+ ndup))) - (push id found) - (push id ids))) - (push (cons (abbreviate-file-name file) ids) reg)))))) - (org-release-buffers org-agenda-new-buffers) - (setq org-agenda-new-buffers nil) - (setq org-id-locations reg) + (let* ((files (delete-dups + (mapcar #'file-truename + (append + ;; Agenda files and all associated archives + (org-agenda-files t org-id-search-archives) + ;; Explicit extra files + (unless (symbolp org-id-extra-files) + org-id-extra-files) + ;; All files known to have IDs + org-id-files + ;; function input + files)))) + (nfiles (length files)) + ids seen-ids (ndup 0) (i 0) file-id-alist) + (with-temp-buffer + (delay-mode-hooks + (org-mode) + (dolist (file files) + (unless silent + (setq i (1+ i)) + (message "Finding ID locations (%d/%d files): %s" + i nfiles file)) + (when (file-exists-p file) + (insert-file-contents file nil nil nil 'replace) + (setq ids (org-map-entries + (lambda () + (org-entry-get (point) "ID")) + "ID<>\"\"")) + (dolist (id ids) + (if (member id seen-ids) + (progn + (message "Duplicate ID \"%s\"" id) + (setq ndup (1+ ndup))) + (push id seen-ids))) + (when ids + (setq file-id-alist (cons (cons (abbreviate-file-name file) ids) + file-id-alist))))))) + (setq org-id-locations file-id-alist) (setq org-id-files (mapcar 'car org-id-locations)) - (org-id-locations-save) ;; this function can also handle the alist form + (org-id-locations-save) ;; now convert to a hash (setq org-id-locations (org-id-alist-to-hash org-id-locations)) - (if (> ndup 0) - (message "WARNING: %d duplicate IDs found, check *Messages* buffer" ndup) - (message "%d unique files scanned for IDs" (length org-id-files))) + (when (> ndup 0) + (warn "WARNING: %d duplicate IDs found, check *Messages* buffer" ndup)) + (message "%d files scanned, %d files contains IDs and in total %d IDs found." + nfiles (length org-id-files) (hash-table-count org-id-locations)) org-id-locations))) (defun org-id-locations-save () @@ -529,6 +534,16 @@ When FILES is given, scan these files instead." (let ((out (if (hash-table-p org-id-locations) (org-id-hash-to-alist org-id-locations) org-id-locations))) + (when (and org-id-locations-file-relative out) + (setq out (mapcar + (lambda (item) + (if (file-name-absolute-p (car item)) + (cons (file-relative-name + (car item) (file-name-directory + org-id-locations-file)) + (cdr item)) + item)) + out))) (with-temp-file org-id-locations-file (let ((print-level nil) (print-length nil)) @@ -542,7 +557,12 @@ When FILES is given, scan these files instead." (condition-case nil (progn (insert-file-contents org-id-locations-file) - (setq org-id-locations (read (current-buffer)))) + (setq org-id-locations (read (current-buffer))) + (let ((loc (file-name-directory org-id-locations-file))) + (mapc (lambda (item) + (unless (file-name-absolute-p (car item)) + (setf (car item) (expand-file-name (car item) loc)))) + org-id-locations))) (error (message "Could not read org-id-values from %s. Setting it to nil." org-id-locations-file)))) @@ -552,10 +572,12 @@ When FILES is given, scan these files instead." (defun org-id-add-location (id file) "Add the ID with location FILE to the database of ID locations." ;; Only if global tracking is on, and when the buffer has a file - (when (and org-id-track-globally id file) - (unless org-id-locations (org-id-locations-load)) - (puthash id (abbreviate-file-name file) org-id-locations) - (add-to-list 'org-id-files (abbreviate-file-name file)))) + (let ((afile (abbreviate-file-name file))) + (when (and org-id-track-globally id file) + (unless org-id-locations (org-id-locations-load)) + (puthash id afile org-id-locations) + (unless (member afile org-id-files) + (add-to-list 'org-id-files afile))))) (unless noninteractive (add-hook 'kill-emacs-hook 'org-id-locations-save)) @@ -565,7 +587,7 @@ When FILES is given, scan these files instead." (let (res x) (maphash (lambda (k v) - (if (setq x (member v res)) + (if (setq x (assoc v res)) (setcdr x (cons k (cdr x))) (push (list v k) res))) hash) @@ -649,7 +671,7 @@ optional argument MARKERP, return the position as a new marker." (match-string 4) (match-string 0))) link)))) - (org-store-link-props :link link :description desc :type "id") + (org-link-store-props :link link :description desc :type "id") link))) (defun org-id-open (id) diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el index 4904d8177e1..a69293a8c8e 100644 --- a/lisp/org/org-indent.el +++ b/lisp/org/org-indent.el @@ -150,15 +150,16 @@ useful to make it ever so slightly different." ;; Text line prefixes. (aset org-indent--text-line-prefixes n - (concat (org-add-props (make-string (+ n indentation) ?\s) - nil 'face 'org-indent) - (and (> n 0) - (char-to-string org-indent-boundary-char))))))) + (org-add-props + (concat (make-string (+ n indentation) ?\s) + (and (> n 0) + (char-to-string org-indent-boundary-char))) + nil 'face 'org-indent))))) (defsubst org-indent-remove-properties (beg end) "Remove indentations between BEG and END." - (org-with-silent-modifications - (remove-text-properties beg end '(line-prefix nil wrap-prefix nil)))) + (with-silent-modifications + (remove-text-properties beg end '(line-prefix nil wrap-prefix nil)))) ;;;###autoload (define-minor-mode org-indent-mode @@ -332,39 +333,39 @@ stopped." (let* ((case-fold-search t) (limited-re (org-get-limited-outline-regexp)) (level (or (org-current-level) 0)) - (time-limit (and delay (time-add nil delay)))) + (time-limit (and delay (org-time-add nil delay)))) ;; For each line, set `line-prefix' and `wrap-prefix' ;; properties depending on the type of line (headline, inline ;; task, item or other). - (org-with-silent-modifications - (while (and (<= (point) end) (not (eobp))) - (cond - ;; When in asynchronous mode, check if interrupt is - ;; required. - ((and delay (input-pending-p)) (throw 'interrupt (point))) - ;; In asynchronous mode, take a break of - ;; `org-indent-agent-resume-delay' every DELAY to avoid - ;; blocking any other idle timer or process output. - ((and delay (time-less-p time-limit nil)) - (setq org-indent-agent-resume-timer - (run-with-idle-timer - (time-add (current-idle-time) org-indent-agent-resume-delay) - nil #'org-indent-initialize-agent)) - (throw 'interrupt (point))) - ;; Headline or inline task. - ((looking-at org-outline-regexp) - (let* ((nstars (- (match-end 0) (match-beginning 0) 1)) - (type (or (looking-at-p limited-re) 'inlinetask))) - (org-indent-set-line-properties nstars 0 type) - ;; At an headline, define new value for LEVEL. - (unless (eq type 'inlinetask) (setq level nstars)))) - ;; List item: `wrap-prefix' is set where body starts. - ((org-at-item-p) - (org-indent-set-line-properties - level (org-list-item-body-column (point)))) - ;; Regular line. - (t - (org-indent-set-line-properties level (org-get-indentation)))))))))) + (with-silent-modifications + (while (and (<= (point) end) (not (eobp))) + (cond + ;; When in asynchronous mode, check if interrupt is + ;; required. + ((and delay (input-pending-p)) (throw 'interrupt (point))) + ;; In asynchronous mode, take a break of + ;; `org-indent-agent-resume-delay' every DELAY to avoid + ;; blocking any other idle timer or process output. + ((and delay (org-time-less-p time-limit nil)) + (setq org-indent-agent-resume-timer + (run-with-idle-timer + (time-add (current-idle-time) org-indent-agent-resume-delay) + nil #'org-indent-initialize-agent)) + (throw 'interrupt (point))) + ;; Headline or inline task. + ((looking-at org-outline-regexp) + (let* ((nstars (- (match-end 0) (match-beginning 0) 1)) + (type (or (looking-at-p limited-re) 'inlinetask))) + (org-indent-set-line-properties nstars 0 type) + ;; At an headline, define new value for LEVEL. + (unless (eq type 'inlinetask) (setq level nstars)))) + ;; List item: `wrap-prefix' is set where body starts. + ((org-at-item-p) + (org-indent-set-line-properties + level (org-list-item-body-column (point)))) + ;; Regular line. + (t + (org-indent-set-line-properties level (current-indentation)))))))))) (defun org-indent-notify-modified-headline (beg end) "Set `org-indent-modified-headline-flag' depending on context. diff --git a/lisp/org/org-inlinetask.el b/lisp/org/org-inlinetask.el index 82372e59dcd..c76d7d20938 100644 --- a/lisp/org/org-inlinetask.el +++ b/lisp/org/org-inlinetask.el @@ -40,9 +40,9 @@ ;; parent into children. ;; ;; Special fontification of inline tasks, so that they can be -;; immediately recognized. From the stars of the headline, only the -;; first and the last two will be visible, the others will be hidden -;; using the `org-hide' face. +;; immediately recognized. From the stars of the headline, only last +;; two will be visible, the others will be hidden using the `org-hide' +;; face. ;; ;; An inline task is identified solely by a minimum outline level, ;; given by the variable `org-inlinetask-min-level', default 15. @@ -54,14 +54,14 @@ ;; ;; As an example, here are two valid inline tasks: ;; -;; **************** TODO a small task +;; **************** TODO A small task ;; ;; and ;; -;; **************** TODO another small task +;; **************** TODO Another small task ;; DEADLINE: <2009-03-30 Mon> ;; :PROPERTIES: -;; :SOMETHING: or other +;; :SOMETHING: another thing ;; :END: ;; And here is some extra text ;; **************** END @@ -123,7 +123,8 @@ default, or nil if no state should be assigned." (defun org-inlinetask-insert-task (&optional no-state) "Insert an inline task. -If prefix arg NO-STATE is set, ignore `org-inlinetask-default-state'." +If prefix arg NO-STATE is set, ignore `org-inlinetask-default-state'. +If there is a region wrap it inside the inline task." (interactive "P") ;; Error when inside an inline task, except if point was at its very ;; beginning, in which case the new inline task will be inserted @@ -135,13 +136,19 @@ If prefix arg NO-STATE is set, ignore `org-inlinetask-default-state'." (let* ((indent (if org-odd-levels-only (1- (* 2 org-inlinetask-min-level)) org-inlinetask-min-level)) - (indent-string (concat (make-string indent ?*) " "))) + (indent-string (concat (make-string indent ?*) " ")) + (rbeg (if (org-region-active-p) (region-beginning) (point))) + (rend (if (org-region-active-p) (region-end) (point)))) + (goto-char rend) + (insert "\n" indent-string "END\n") + (goto-char rbeg) + (unless (bolp) (insert "\n")) (insert indent-string (if (or no-state (not org-inlinetask-default-state)) - "\n" - (concat org-inlinetask-default-state " \n")) - indent-string "END\n")) - (end-of-line -1)) + "" + (concat org-inlinetask-default-state " ")) + (if (= rend rbeg) "" "\n")) + (unless (= rend rbeg) (end-of-line 0)))) (define-key org-mode-map "\C-c\C-xt" 'org-inlinetask-insert-task) (defun org-inlinetask-outline-regexp () @@ -152,24 +159,24 @@ The number of levels is controlled by `org-inlinetask-min-level'." org-inlinetask-min-level))) (format "^\\(\\*\\{%d,\\}\\)[ \t]+" nstars))) +(defun org-inlinetask-end-p () + "Return a non-nil value if point is on inline task's END part." + (let ((case-fold-search t)) + (org-match-line (concat (org-inlinetask-outline-regexp) "END[ \t]*$")))) + (defun org-inlinetask-at-task-p () - "Return true if point is at beginning of an inline task." - (save-excursion - (beginning-of-line) - (and (looking-at (concat (org-inlinetask-outline-regexp) "\\(.*\\)")) - (not (string-match "^end[ \t]*$" (downcase (match-string 2))))))) + "Return non-nil if point is at beginning of an inline task." + (and (org-match-line (concat (org-inlinetask-outline-regexp) "\\(.*\\)")) + (not (org-inlinetask-end-p)))) (defun org-inlinetask-in-task-p () "Return true if point is inside an inline task." (save-excursion (beginning-of-line) - (let* ((case-fold-search t) - (stars-re (org-inlinetask-outline-regexp)) - (task-beg-re (concat stars-re "\\(?:.*\\)")) - (task-end-re (concat stars-re "END[ \t]*$"))) - (or (looking-at-p task-beg-re) + (let ((case-fold-search t)) + (or (looking-at-p (concat (org-inlinetask-outline-regexp) "\\(?:.*\\)")) (and (re-search-forward "^\\*+[ \t]+" nil t) - (progn (beginning-of-line) (looking-at-p task-end-re))))))) + (org-inlinetask-end-p)))))) (defun org-inlinetask-goto-beginning () "Go to the beginning of the inline task at point." @@ -177,7 +184,7 @@ The number of levels is controlled by `org-inlinetask-min-level'." (let ((case-fold-search t) (inlinetask-re (org-inlinetask-outline-regexp))) (re-search-backward inlinetask-re nil t) - (when (looking-at-p (concat inlinetask-re "END[ \t]*$")) + (when (org-inlinetask-end-p) (re-search-backward inlinetask-re nil t)))) (defun org-inlinetask-goto-end () @@ -185,16 +192,15 @@ The number of levels is controlled by `org-inlinetask-min-level'." Return point." (save-match-data (beginning-of-line) - (let* ((case-fold-search t) - (inlinetask-re (org-inlinetask-outline-regexp)) - (task-end-re (concat inlinetask-re "END[ \t]*$"))) + (let ((case-fold-search t) + (inlinetask-re (org-inlinetask-outline-regexp))) (cond - ((looking-at-p task-end-re) + ((org-inlinetask-end-p) (forward-line)) ((looking-at-p inlinetask-re) (forward-line) (cond - ((looking-at-p task-end-re) (forward-line)) + ((org-inlinetask-end-p) (forward-line)) ((looking-at-p inlinetask-re)) ((org-inlinetask-in-task-p) (re-search-forward inlinetask-re nil t) @@ -262,17 +268,6 @@ If the task has an end part, also demote it." (goto-char beg) (org-fixup-indentation diff))))))) -(defun org-inlinetask-get-current-indentation () - "Get the indentation of the last non-while line above this one." - (save-excursion - (beginning-of-line 1) - (skip-chars-backward " \t\n") - (beginning-of-line 1) - (or (org-at-item-p) - (looking-at "[ \t]*")) - (goto-char (match-end 0)) - (current-column))) - (defvar org-indent-indentation-per-level) ; defined in org-indent.el (defface org-inlinetask '((t :inherit shadow)) @@ -317,9 +312,8 @@ If the task has an end part, also demote it." ((= end start)) ;; Inlinetask was folded: expand it. ((eq (get-char-property (1+ start) 'invisible) 'outline) - (outline-flag-region start end nil) - (org-cycle-hide-drawers 'children)) - (t (outline-flag-region start end t))))) + (org-flag-region start end nil 'outline)) + (t (org-flag-region start end t 'outline))))) (defun org-inlinetask-hide-tasks (state) "Hide inline tasks in buffer when STATE is `contents' or `children'. diff --git a/lisp/org/org-keys.el b/lisp/org/org-keys.el new file mode 100644 index 00000000000..ae4f60de9b9 --- /dev/null +++ b/lisp/org/org-keys.el @@ -0,0 +1,924 @@ +;;; org-keys.el --- Key bindings for Org mode -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library adds bindings for Org mode buffers. It also +;; implements both Speed keys and Babel speed keys. See manual for +;; details. + +;;; Code: + +(defvar org-outline-regexp) + +(declare-function org-add-note "org" ()) +(declare-function org-agenda "org" (&optional arg org-keys restriction)) +(declare-function org-agenda-file-to-front "org" (&optional to-end)) +(declare-function org-agenda-remove-restriction-lock "org" (&optional noupdate)) +(declare-function org-agenda-set-restriction-lock "org" (&optional type)) +(declare-function org-archive-subtree "org" (&optional find-done)) +(declare-function org-archive-subtree-default "org" ()) +(declare-function org-archive-subtree-default-with-confirmation "org" ()) +(declare-function org-archive-to-archive-sibling "org" ()) +(declare-function org-at-heading-p "org" (&optional ignored)) +(declare-function org-attach "org" ()) +(declare-function org-backward-element "org" ()) +(declare-function org-backward-heading-same-level "org" (arg &optional invisible-ok)) +(declare-function org-backward-paragraph "org" ()) +(declare-function org-backward-sentence "org" (&optional arg)) +(declare-function org-beginning-of-line "org" (&optional n)) +(declare-function org-clock-cancel "org" ()) +(declare-function org-clock-display "org" (&optional arg)) +(declare-function org-clock-goto "org" (&optional select)) +(declare-function org-clock-in "org" (&optional select start-time)) +(declare-function org-clock-in-last "org" (&optional arg)) +(declare-function org-clock-out "org" (&optional switch-to-state fail-quietly at-time)) +(declare-function org-clone-subtree-with-time-shift "org" (n &optional shift)) +(declare-function org-columns "org" (&optional global columns-fmt-string)) +(declare-function org-comment-dwim "org" (arg)) +(declare-function org-copy "org" ()) +(declare-function org-copy-special "org" ()) +(declare-function org-copy-visible "org" (beg end)) +(declare-function org-ctrl-c-ctrl-c "org" (&optional arg)) +(declare-function org-ctrl-c-minus "org" ()) +(declare-function org-ctrl-c-ret "org" ()) +(declare-function org-ctrl-c-star "org" ()) +(declare-function org-ctrl-c-tab "org" (&optional arg)) +(declare-function org-cut-special "org" ()) +(declare-function org-cut-subtree "org" (&optional n)) +(declare-function org-cycle "org" (&optional arg)) +(declare-function org-cycle-agenda-files "org" ()) +(declare-function org-date-from-calendar "org" ()) +(declare-function org-dynamic-block-insert-dblock "org" (&optional arg)) +(declare-function org-dblock-update "org" (&optional arg)) +(declare-function org-deadline "org" (arg1 &optional time)) +(declare-function org-decrease-number-at-point "org" (&optional inc)) +(declare-function org-delete-backward-char "org" (n)) +(declare-function org-delete-char "org" (n)) +(declare-function org-delete-indentation "org" (&optional arg)) +(declare-function org-demote-subtree "org" ()) +(declare-function org-display-outline-path "org" (&optional file current separator just-return-string)) +(declare-function org-down-element "org" ()) +(declare-function org-edit-special "org" (&optional arg)) +(declare-function org-element-at-point "org-element" ()) +(declare-function org-element-type "org-element" (element)) +(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-evaluate-time-range "org" (&optional to-buffer)) +(declare-function org-export-dispatch "org" (&optional arg)) +(declare-function org-feed-goto-inbox "org" (feed)) +(declare-function org-feed-update-all "org" ()) +(declare-function org-fill-paragraph "org" (&optional justify region)) +(declare-function org-find-file-at-mouse "org" (ev)) +(declare-function org-footnote-action "org" (&optional special)) +(declare-function org-force-cycle-archived "org" ()) +(declare-function org-force-self-insert "org" (n)) +(declare-function org-forward-element "org" ()) +(declare-function org-forward-heading-same-level "org" (arg &optional invisible-ok)) +(declare-function org-forward-paragraph "org" ()) +(declare-function org-forward-sentence "org" (&optional arg)) +(declare-function org-goto "org" (&optional alternative-interface)) +(declare-function org-goto-calendar "org" (&optional arg)) +(declare-function org-inc-effort "org" ()) +(declare-function org-increase-number-at-point "org" (&optional inc)) +(declare-function org-info-find-node "org" (&optional nodename)) +(declare-function org-insert-all-links "org" (arg &optional pre post)) +(declare-function org-insert-drawer "org" (&optional arg drawer)) +(declare-function org-insert-heading-respect-content "org" (&optional invisible-ok)) +(declare-function org-insert-last-stored-link "org" (arg)) +(declare-function org-insert-link "org" (&optional complete-file link-location default-description)) +(declare-function org-insert-structure-template "org" (type)) +(declare-function org-insert-todo-heading "org" (arg &optional force-heading)) +(declare-function org-insert-todo-heading-respect-content "org" (&optional force-state)) +(declare-function org-kill-line "org" (&optional arg)) +(declare-function org-kill-note-or-show-branches "org" ()) +(declare-function org-list-make-subtree "org" ()) +(declare-function org-mark-element "org" ()) +(declare-function org-mark-ring-goto "org" (&optional n)) +(declare-function org-mark-ring-push "org" (&optional pos buffer)) +(declare-function org-mark-subtree "org" (&optional up)) +(declare-function org-match-sparse-tree "org" (&optional todo-only match)) +(declare-function org-meta-return "org" (&optional arg)) +(declare-function org-metadown "org" (&optional _arg)) +(declare-function org-metaleft "org" (&optional _)) +(declare-function org-metaright "org" (&optional _arg)) +(declare-function org-metaup "org" (&optional _arg)) +(declare-function org-narrow-to-block "org" ()) +(declare-function org-narrow-to-element "org" ()) +(declare-function org-narrow-to-subtree "org" ()) +(declare-function org-next-block "org" (arg &optional backward block-regexp)) +(declare-function org-next-link "org" (&optional search-backward)) +(declare-function org-next-visible-heading "org" (arg)) +(declare-function org-open-at-mouse "org" (ev)) +(declare-function org-open-at-point "org" (&optional arg reference-buffer)) +(declare-function org-open-line "org" (n)) +(declare-function org-paste-special "org" (arg)) +(declare-function org-plot/gnuplot "org-plot" (&optional params)) +(declare-function org-previous-block "org" (arg &optional block-regexp)) +(declare-function org-previous-link "org" ()) +(declare-function org-previous-visible-heading "org" (arg)) +(declare-function org-priority "org" (&optional action show)) +(declare-function org-promote-subtree "org" ()) +(declare-function org-redisplay-inline-images "org" ()) +(declare-function org-refile "org" (&optional arg1 default-buffer rfloc msg)) +(declare-function org-reftex-citation "org" ()) +(declare-function org-reload "org" (&optional arg1)) +(declare-function org-remove-file "org" (&optional file)) +(declare-function org-resolve-clocks "org" (&optional only-dangling-p prompt-fn last-valid)) +(declare-function org-return "org" (&optional indent)) +(declare-function org-return-indent "org" ()) +(declare-function org-reveal "org" (&optional siblings)) +(declare-function org-schedule "org" (arg &optional time)) +(declare-function org-self-insert-command "org" (N)) +(declare-function org-set-effort "org" (&optional increment value)) +(declare-function org-set-property "org" (property value)) +(declare-function org-set-property-and-value "org" (use-last)) +(declare-function org-set-tags-command "org" (&optional arg)) +(declare-function org-shiftcontroldown "org" (&optional n)) +(declare-function org-shiftcontrolleft "org" ()) +(declare-function org-shiftcontrolright "org" ()) +(declare-function org-shiftcontrolup "org" (&optional n)) +(declare-function org-shiftdown "org" (&optional arg)) +(declare-function org-shiftleft "org" (&optional arg)) +(declare-function org-shiftmetadown "org" (&optional _arg)) +(declare-function org-shiftmetaleft "org" ()) +(declare-function org-shiftmetaright "org" ()) +(declare-function org-shiftmetaup "org" (&optional arg)) +(declare-function org-shiftright "org" (&optional arg)) +(declare-function org-shifttab "org" (&optional arg)) +(declare-function org-shiftup "org" (&optional arg)) +(declare-function org-show-all "org" (&optional types)) +(declare-function org-show-children "org" (&optional level)) +(declare-function org-show-subtree "org" ()) +(declare-function org-sort "org" (&optional with-case)) +(declare-function org-sparse-tree "org" (&optional arg type)) +(declare-function org-table-blank-field "org" ()) +(declare-function org-table-copy-down "org" (n)) +(declare-function org-table-create-or-convert-from-region "org" (arg)) +(declare-function org-table-create-with-table\.el "org-table" ()) +(declare-function org-table-edit-field "org" (arg)) +(declare-function org-table-eval-formula "org" (&optional arg equation suppress-align suppress-const suppress-store suppress-analysis)) +(declare-function org-table-field-info "org" (arg)) +(declare-function org-table-rotate-recalc-marks "org" (&optional newchar)) +(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-timer "org" (&optional restart no-insert)) +(declare-function org-timer-item "org" (&optional arg)) +(declare-function org-timer-pause-or-continue "org" (&optional stop)) +(declare-function org-timer-set-timer "org" (&optional opt)) +(declare-function org-timer-start "org" (&optional offset)) +(declare-function org-timer-stop "org" ()) +(declare-function org-todo "org" (&optional arg1)) +(declare-function org-toggle-archive-tag "org" (&optional find-done)) +(declare-function org-toggle-checkbox "org" (&optional toggle-presence)) +(declare-function org-toggle-comment "org" ()) +(declare-function org-toggle-fixed-width "org" ()) +(declare-function org-toggle-inline-images "org" (&optional include-linked)) +(declare-function org-latex-preview "org" (&optional arg)) +(declare-function org-toggle-narrow-to-subtree "org" ()) +(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-transpose-element "org" ()) +(declare-function org-transpose-words "org" ()) +(declare-function org-tree-to-indirect-buffer "org" (&optional arg)) +(declare-function org-up-element "org" ()) +(declare-function org-update-statistics-cookies "org" (all)) +(declare-function org-yank "org" (&optional arg)) +(declare-function orgtbl-ascii-plot "org-table" (&optional ask)) + + + +;;; Variables + +(defvar org-mode-map (make-sparse-keymap) + "Keymap fo Org mode.") + +(defcustom org-replace-disputed-keys nil + "Non-nil means use alternative key bindings for some keys. + +Org mode uses S-<cursor> keys for changing timestamps and priorities. +These keys are also used by other packages like Shift Select mode, +CUA mode or Windmove. If you want to use Org mode together with +one of these other modes, or more generally if you would like to +move some Org mode commands to other keys, set this variable and +configure the keys with the variable `org-disputed-keys'. + +This option is only relevant at load-time of Org mode, and must be set +*before* org.el is loaded. Changing it requires a restart of Emacs to +become effective." + :group 'org-startup + :type 'boolean + :safe #'booleanp) + +(defcustom org-use-extra-keys nil + "Non-nil means use extra key sequence definitions for certain commands. +This happens automatically if `window-system' is nil. This +variable lets you do the same manually. You must set it before +loading Org." + :group 'org-startup + :type 'boolean + :safe #'booleanp) + +(defvaralias 'org-CUA-compatible 'org-replace-disputed-keys) + +(defcustom org-disputed-keys + '(([(shift up)] . [(meta p)]) + ([(shift down)] . [(meta n)]) + ([(shift left)] . [(meta -)]) + ([(shift right)] . [(meta +)]) + ([(control shift right)] . [(meta shift +)]) + ([(control shift left)] . [(meta shift -)])) + "Keys for which Org mode and other modes compete. +This is an alist, cars are the default keys, second element specifies +the alternative to use when `org-replace-disputed-keys' is t. + +Keys can be specified in any syntax supported by `define-key'. +The value of this option takes effect only at Org mode startup, +therefore you'll have to restart Emacs to apply it after changing." + :group 'org-startup + :type 'alist) + +(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. +A longer mouse click will still set point. Needs to be set +before org.el is loaded." + :group 'org-link-follow + :version "26.1" + :package-version '(Org . "8.3") + :type '(choice + (const :tag "A double click follows the link" double) + (const :tag "Unconditionally follow the link with mouse-1" t) + (integer :tag "mouse-1 click does not follow the link if longer than N ms" 450)) + :safe t) + +(defcustom org-tab-follows-link nil + "Non-nil means on links TAB will follow the link. +Needs to be set before Org is loaded. +This really should not be used, it does not make sense, and the +implementation is bad." + :group 'org-link-follow + :type 'boolean) + +(defcustom org-follow-link-hook nil + "Hook that is run after a link has been followed." + :group 'org-link-follow + :type 'hook) + +(defcustom org-return-follows-link nil + "Non-nil means on links RET will follow the link. +In tables, the special behavior of RET has precedence." + :group 'org-link-follow + :type 'boolean + :safe t) + + +;;; Functions + +;;;; Base functions +(defun org-key (key) + "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)) + (x (cl-find-if (lambda (x) (equal (key-description (car x)) nkey)) + org-disputed-keys))) + (setq key (if x (cdr x) key)))) + key) + +(defun org-defkey (keymap key def) + "Define a key, possibly translated, as returned by `org-key'." + (define-key keymap (org-key key) def)) + +(defun org-remap (map &rest commands) + "In MAP, remap the functions given in COMMANDS. +COMMANDS is a list of alternating OLDDEF NEWDEF command names." + (let (new old) + (while commands + (setq old (pop commands) new (pop commands)) + (org-defkey map (vector 'remap old) new)))) + + +;;; Mouse map + +(defvar org-mouse-map (make-sparse-keymap)) +(org-defkey org-mouse-map [mouse-2] 'org-open-at-mouse) +(org-defkey org-mouse-map [mouse-3] 'org-find-file-at-mouse) + +(when org-mouse-1-follows-link + (org-defkey org-mouse-map [follow-link] 'mouse-face)) + +(when org-tab-follows-link + (org-defkey org-mouse-map (kbd "<tab>") #'org-open-at-point) + (org-defkey org-mouse-map (kbd "TAB") #'org-open-at-point)) + + +;;; Read date map + +(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)))) + map) + "Keymap for minibuffer commands when using `org-read-date'.") + + +;;; Global bindings + +;;;; Outline functions +(define-key org-mode-map [menu-bar headings] 'undefined) +(define-key org-mode-map [menu-bar hide] 'undefined) +(define-key org-mode-map [menu-bar show] 'undefined) + +(define-key org-mode-map [remap outline-mark-subtree] #'org-mark-subtree) +(define-key org-mode-map [remap outline-show-subtree] #'org-show-subtree) +(define-key org-mode-map [remap outline-forward-same-level] + #'org-forward-heading-same-level) +(define-key org-mode-map [remap outline-backward-same-level] + #'org-backward-heading-same-level) +(define-key org-mode-map [remap outline-show-branches] + #'org-kill-note-or-show-branches) +(define-key org-mode-map [remap outline-promote] #'org-promote-subtree) +(define-key org-mode-map [remap outline-demote] #'org-demote-subtree) +(define-key org-mode-map [remap outline-insert-heading] #'org-ctrl-c-ret) +(define-key org-mode-map [remap outline-next-visible-heading] + #'org-next-visible-heading) +(define-key org-mode-map [remap outline-previous-visible-heading] + #'org-previous-visible-heading) +(define-key org-mode-map [remap show-children] #'org-show-children) + +;;;; Make `C-c C-x' a prefix key +(org-defkey org-mode-map (kbd "C-c C-x") (make-sparse-keymap)) + +;;;; TAB key with modifiers +(org-defkey org-mode-map (kbd "C-i") #'org-cycle) +(org-defkey org-mode-map (kbd "<tab>") #'org-cycle) +(org-defkey org-mode-map (kbd "C-<tab>") #'org-force-cycle-archived) +;; Override text-mode binding to expose `complete-symbol' for +;; pcomplete functionality. +(org-defkey org-mode-map (kbd "M-<tab>") nil) +(org-defkey org-mode-map (kbd "M-TAB") nil) +(org-defkey org-mode-map (kbd "ESC <tab>") nil) +(org-defkey org-mode-map (kbd "ESC TAB") nil) + +(org-defkey org-mode-map (kbd "<S-iso-leftab>") #'org-shifttab) +(org-defkey org-mode-map (kbd "S-<tab>") #'org-shifttab) +(org-defkey org-mode-map (kbd "S-TAB") #'org-shifttab) +(define-key org-mode-map (kbd "<backtab>") #'org-shifttab) + +;;;; RET/<return> key with modifiers +(org-defkey org-mode-map (kbd "S-<return>") #'org-table-copy-down) +(org-defkey org-mode-map (kbd "S-RET") #'org-table-copy-down) +(org-defkey org-mode-map (kbd "M-S-<return>") #'org-insert-todo-heading) +(org-defkey org-mode-map (kbd "M-S-RET") #'org-insert-todo-heading) +(org-defkey org-mode-map (kbd "ESC S-<return>") #'org-insert-todo-heading) +(org-defkey org-mode-map (kbd "ESC S-RET") #'org-insert-todo-heading) +(org-defkey org-mode-map (kbd "M-<return>") #'org-meta-return) +(org-defkey org-mode-map (kbd "M-RET") #'org-meta-return) +(org-defkey org-mode-map (kbd "ESC <return>") #'org-meta-return) +(org-defkey org-mode-map (kbd "ESC RET") #'org-meta-return) + +;;;; Cursor keys with modifiers +(org-defkey org-mode-map (kbd "M-<left>") #'org-metaleft) +(org-defkey org-mode-map (kbd "M-<right>") #'org-metaright) +(org-defkey org-mode-map (kbd "ESC <right>") #'org-metaright) +(org-defkey org-mode-map (kbd "M-<up>") #'org-metaup) +(org-defkey org-mode-map (kbd "ESC <up>") #'org-metaup) +(org-defkey org-mode-map (kbd "M-<down>") #'org-metadown) +(org-defkey org-mode-map (kbd "ESC <down>") #'org-metadown) + +(org-defkey org-mode-map (kbd "C-M-S-<right>") #'org-increase-number-at-point) +(org-defkey org-mode-map (kbd "C-M-S-<left>") #'org-decrease-number-at-point) +(org-defkey org-mode-map (kbd "M-S-<left>") #'org-shiftmetaleft) +(org-defkey org-mode-map (kbd "ESC S-<left>") #'org-shiftmetaleft) +(org-defkey org-mode-map (kbd "M-S-<right>") #'org-shiftmetaright) +(org-defkey org-mode-map (kbd "ESC S-<right>") #'org-shiftmetaright) +(org-defkey org-mode-map (kbd "M-S-<up>") #'org-shiftmetaup) +(org-defkey org-mode-map (kbd "ESC S-<up>") #'org-shiftmetaup) +(org-defkey org-mode-map (kbd "M-S-<down>") #'org-shiftmetadown) +(org-defkey org-mode-map (kbd "ESC S-<down>") #'org-shiftmetadown) + +(org-defkey org-mode-map (kbd "S-<up>") #'org-shiftup) +(org-defkey org-mode-map (kbd "S-<down>") #'org-shiftdown) +(org-defkey org-mode-map (kbd "S-<left>") #'org-shiftleft) +(org-defkey org-mode-map (kbd "S-<right>") #'org-shiftright) + +(org-defkey org-mode-map (kbd "C-S-<right>") #'org-shiftcontrolright) +(org-defkey org-mode-map (kbd "C-S-<left>") #'org-shiftcontrolleft) +(org-defkey org-mode-map (kbd "C-S-<up>") #'org-shiftcontrolup) +(org-defkey org-mode-map (kbd "C-S-<down>") #'org-shiftcontroldown) + +;;;; Extra keys for TTY access. + +;; We only set them when really needed because otherwise the +;; menus don't show the simple keys + +(when (or org-use-extra-keys (not window-system)) + (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 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) + (org-defkey org-mode-map (kbd "C-c C-x l") #'org-metaleft) + (org-defkey org-mode-map (kbd "ESC <right>") #'org-metaright) + (org-defkey org-mode-map (kbd "C-c C-x r") #'org-metaright) + (org-defkey org-mode-map (kbd "C-c C-x u") #'org-metaup) + (org-defkey org-mode-map (kbd "C-c C-x d") #'org-metadown) + (org-defkey org-mode-map (kbd "C-c C-x L") #'org-shiftmetaleft) + (org-defkey org-mode-map (kbd "C-c C-x R") #'org-shiftmetaright) + (org-defkey org-mode-map (kbd "C-c C-x U") #'org-shiftmetaup) + (org-defkey org-mode-map (kbd "C-c C-x D") #'org-shiftmetadown) + (org-defkey org-mode-map (kbd "C-c <up>") #'org-shiftup) + (org-defkey org-mode-map (kbd "C-c <down>") #'org-shiftdown) + (org-defkey org-mode-map (kbd "C-c <left>") #'org-shiftleft) + (org-defkey org-mode-map (kbd "C-c <right>") #'org-shiftright) + (org-defkey org-mode-map (kbd "C-c C-x <right>") #'org-shiftcontrolright) + (org-defkey org-mode-map (kbd "C-c C-x <left>") #'org-shiftcontrolleft)) + +;;;; Narrowing bindings +(org-defkey org-mode-map (kbd "C-x n s") #'org-narrow-to-subtree) +(org-defkey org-mode-map (kbd "C-x n b") #'org-narrow-to-block) +(org-defkey org-mode-map (kbd "C-x n e") #'org-narrow-to-element) + +;;;; Remap usual Emacs bindings +(org-remap org-mode-map + 'self-insert-command 'org-self-insert-command + 'delete-char 'org-delete-char + 'delete-backward-char 'org-delete-backward-char + 'kill-line 'org-kill-line + 'open-line 'org-open-line + 'yank 'org-yank + 'comment-dwim 'org-comment-dwim + 'move-beginning-of-line 'org-beginning-of-line + 'move-end-of-line 'org-end-of-line + 'forward-paragraph 'org-forward-paragraph + 'backward-paragraph 'org-backward-paragraph + 'backward-sentence 'org-backward-sentence + 'forward-sentence 'org-forward-sentence + 'fill-paragraph 'org-fill-paragraph + 'delete-indentation 'org-delete-indentation + 'transpose-words 'org-transpose-words) + +;;;; All the other keys +(org-defkey org-mode-map (kbd "|") #'org-force-self-insert) +(org-defkey org-mode-map (kbd "C-c C-r") #'org-reveal) +(org-defkey org-mode-map (kbd "C-M-t") #'org-transpose-element) +(org-defkey org-mode-map (kbd "M-}") #'org-forward-element) +(org-defkey org-mode-map (kbd "ESC }") #'org-forward-element) +(org-defkey org-mode-map (kbd "M-{") #'org-backward-element) +(org-defkey org-mode-map (kbd "ESC {") #'org-backward-element) +(org-defkey org-mode-map (kbd "C-c C-^") #'org-up-element) +(org-defkey org-mode-map (kbd "C-c C-_") #'org-down-element) +(org-defkey org-mode-map (kbd "C-c C-f") #'org-forward-heading-same-level) +(org-defkey org-mode-map (kbd "C-c C-b") #'org-backward-heading-same-level) +(org-defkey org-mode-map (kbd "C-c M-f") #'org-next-block) +(org-defkey org-mode-map (kbd "C-c M-b") #'org-previous-block) +(org-defkey org-mode-map (kbd "C-c $") #'org-archive-subtree) +(org-defkey org-mode-map (kbd "C-c C-x C-s") #'org-archive-subtree) +(org-defkey org-mode-map (kbd "C-c C-x C-a") #'org-archive-subtree-default) +(org-defkey org-mode-map (kbd "C-c C-x d") #'org-insert-drawer) +(org-defkey org-mode-map (kbd "C-c C-x a") #'org-toggle-archive-tag) +(org-defkey org-mode-map (kbd "C-c C-x A") #'org-archive-to-archive-sibling) +(org-defkey org-mode-map (kbd "C-c C-x b") #'org-tree-to-indirect-buffer) +(org-defkey org-mode-map (kbd "C-c C-x q") #'org-toggle-tags-groups) +(org-defkey org-mode-map (kbd "C-c C-j") #'org-goto) +(org-defkey org-mode-map (kbd "C-c C-t") #'org-todo) +(org-defkey org-mode-map (kbd "C-c C-q") #'org-set-tags-command) +(org-defkey org-mode-map (kbd "C-c C-s") #'org-schedule) +(org-defkey org-mode-map (kbd "C-c C-d") #'org-deadline) +(org-defkey org-mode-map (kbd "C-c ;") #'org-toggle-comment) +(org-defkey org-mode-map (kbd "C-c C-w") #'org-refile) +(org-defkey org-mode-map (kbd "C-c M-w") #'org-copy) +(org-defkey org-mode-map (kbd "C-c /") #'org-sparse-tree) ;minor-mode reserved +(org-defkey org-mode-map (kbd "C-c \\") #'org-match-sparse-tree) ;minor-mode r. +(org-defkey org-mode-map (kbd "C-c RET") #'org-ctrl-c-ret) +(org-defkey org-mode-map (kbd "C-c C-x c") #'org-clone-subtree-with-time-shift) +(org-defkey org-mode-map (kbd "C-c C-x v") #'org-copy-visible) +(org-defkey org-mode-map (kbd "C-<return>") #'org-insert-heading-respect-content) +(org-defkey org-mode-map (kbd "C-S-<return>") #'org-insert-todo-heading-respect-content) +(org-defkey org-mode-map (kbd "C-c C-x C-n") #'org-next-link) +(org-defkey org-mode-map (kbd "C-c C-x C-p") #'org-previous-link) +(org-defkey org-mode-map (kbd "C-c C-l") #'org-insert-link) +(org-defkey org-mode-map (kbd "C-c M-l") #'org-insert-last-stored-link) +(org-defkey org-mode-map (kbd "C-c C-M-l") #'org-insert-all-links) +(org-defkey org-mode-map (kbd "C-c C-o") #'org-open-at-point) +(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-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) +(org-defkey org-mode-map (kbd "C-c <") #'org-date-from-calendar) +(org-defkey org-mode-map (kbd "C-,") #'org-cycle-agenda-files) +(org-defkey org-mode-map (kbd "C-'") #'org-cycle-agenda-files) +(org-defkey org-mode-map (kbd "C-c [") #'org-agenda-file-to-front) +(org-defkey org-mode-map (kbd "C-c ]") #'org-remove-file) +(org-defkey org-mode-map (kbd "C-c C-x <") #'org-agenda-set-restriction-lock) +(org-defkey org-mode-map (kbd "C-c C-x >") #'org-agenda-remove-restriction-lock) +(org-defkey org-mode-map (kbd "C-c -") #'org-ctrl-c-minus) +(org-defkey org-mode-map (kbd "C-c *") #'org-ctrl-c-star) +(org-defkey org-mode-map (kbd "C-c TAB") #'org-ctrl-c-tab) +(org-defkey org-mode-map (kbd "C-c ^") #'org-sort) +(org-defkey org-mode-map (kbd "C-c C-c") #'org-ctrl-c-ctrl-c) +(org-defkey org-mode-map (kbd "C-c C-k") #'org-kill-note-or-show-branches) +(org-defkey org-mode-map (kbd "C-c #") #'org-update-statistics-cookies) +(org-defkey org-mode-map (kbd "RET") #'org-return) +(org-defkey org-mode-map (kbd "C-j") #'org-return-indent) +(org-defkey org-mode-map (kbd "C-c ?") #'org-table-field-info) +(org-defkey org-mode-map (kbd "C-c SPC") #'org-table-blank-field) +(org-defkey org-mode-map (kbd "C-c +") #'org-table-sum) +(org-defkey org-mode-map (kbd "C-c =") #'org-table-eval-formula) +(org-defkey org-mode-map (kbd "C-c '") #'org-edit-special) +(org-defkey org-mode-map (kbd "C-c `") #'org-table-edit-field) +(org-defkey org-mode-map (kbd "C-c \" a") #'orgtbl-ascii-plot) +(org-defkey org-mode-map (kbd "C-c \" g") #'org-plot/gnuplot) +(org-defkey org-mode-map (kbd "C-c |") #'org-table-create-or-convert-from-region) +(org-defkey org-mode-map (kbd "C-#") #'org-table-rotate-recalc-marks) +(org-defkey org-mode-map (kbd "C-c ~") #'org-table-create-with-table.el) +(org-defkey org-mode-map (kbd "C-c C-a") #'org-attach) +(org-defkey org-mode-map (kbd "C-c }") #'org-table-toggle-coordinate-overlays) +(org-defkey org-mode-map (kbd "C-c {") #'org-table-toggle-formula-debugger) +(org-defkey org-mode-map (kbd "C-c C-e") #'org-export-dispatch) +(org-defkey org-mode-map (kbd "C-c :") #'org-toggle-fixed-width) +(org-defkey org-mode-map (kbd "C-c C-x C-f") #'org-emphasize) +(org-defkey org-mode-map (kbd "C-c C-x f") #'org-footnote-action) +(org-defkey org-mode-map (kbd "C-c @") #'org-mark-subtree) +(org-defkey org-mode-map (kbd "M-h") #'org-mark-element) +(org-defkey org-mode-map (kbd "ESC h") #'org-mark-element) +(org-defkey org-mode-map (kbd "C-c C-*") #'org-list-make-subtree) +(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-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) +(org-defkey org-mode-map (kbd "C-c C-x C-o") #'org-clock-out) +(org-defkey org-mode-map (kbd "C-c C-x C-j") #'org-clock-goto) +(org-defkey org-mode-map (kbd "C-c C-x C-q") #'org-clock-cancel) +(org-defkey org-mode-map (kbd "C-c C-x C-d") #'org-clock-display) +(org-defkey org-mode-map (kbd "C-c C-x x") #'org-dynamic-block-insert-dblock) +(org-defkey org-mode-map (kbd "C-c C-x C-u") #'org-dblock-update) +(org-defkey org-mode-map (kbd "C-c C-x C-l") #'org-latex-preview) +(org-defkey org-mode-map (kbd "C-c C-x C-v") #'org-toggle-inline-images) +(org-defkey org-mode-map (kbd "C-c C-x C-M-v") #'org-redisplay-inline-images) +(org-defkey org-mode-map (kbd "C-c C-x \\") #'org-toggle-pretty-entities) +(org-defkey org-mode-map (kbd "C-c C-x C-b") #'org-toggle-checkbox) +(org-defkey org-mode-map (kbd "C-c C-x p") #'org-set-property) +(org-defkey org-mode-map (kbd "C-c C-x P") #'org-set-property-and-value) +(org-defkey org-mode-map (kbd "C-c C-x e") #'org-set-effort) +(org-defkey org-mode-map (kbd "C-c C-x E") #'org-inc-effort) +(org-defkey org-mode-map (kbd "C-c C-x o") #'org-toggle-ordered-property) +(org-defkey org-mode-map (kbd "C-c C-,") #'org-insert-structure-template) +(org-defkey org-mode-map (kbd "C-c C-x .") #'org-timer) +(org-defkey org-mode-map (kbd "C-c C-x -") #'org-timer-item) +(org-defkey org-mode-map (kbd "C-c C-x 0") #'org-timer-start) +(org-defkey org-mode-map (kbd "C-c C-x _") #'org-timer-stop) +(org-defkey org-mode-map (kbd "C-c C-x ;") #'org-timer-set-timer) +(org-defkey org-mode-map (kbd "C-c C-x ,") #'org-timer-pause-or-continue) +(org-defkey org-mode-map (kbd "C-c C-x C-c") #'org-columns) +(org-defkey org-mode-map (kbd "C-c C-x !") #'org-reload) +(org-defkey org-mode-map (kbd "C-c C-x g") #'org-feed-update-all) +(org-defkey org-mode-map (kbd "C-c C-x G") #'org-feed-goto-inbox) +(org-defkey org-mode-map (kbd "C-c C-x [") #'org-reftex-citation) +(org-defkey org-mode-map (kbd "C-c C-x I") #'org-info-find-node) + + +;;; Speed keys + +(defcustom org-use-speed-commands nil + "Non-nil means activate single letter commands at beginning of a headline. +This may also be a function to test for appropriate locations where speed +commands should be active. + +For example, to activate speed commands when the point is on any +star at the beginning of the headline, you can do this: + + (setq org-use-speed-commands + (lambda () (and (looking-at org-outline-regexp) (looking-back \"^\\**\"))))" + :group 'org-structure + :type '(choice + (const :tag "Never" nil) + (const :tag "At beginning of headline stars" t) + (function))) + +(defcustom org-speed-commands-user nil + "Alist of additional speed commands. +This list will be checked before `org-speed-commands-default' +when the variable `org-use-speed-commands' is non-nil +and when the cursor is at the beginning of a headline. +The car of each entry is a string with a single letter, which must +be assigned to `self-insert-command' in the global map. +The cdr is either a command to be called interactively, a function +to be called, or a form to be evaluated. +An entry that is just a list with a single string will be interpreted +as a descriptive headline that will be added when listing the speed +commands in the Help buffer using the `?' speed command." + :group 'org-structure + :type '(repeat :value ("k" . ignore) + (choice :value ("k" . ignore) + (list :tag "Descriptive Headline" (string :tag "Headline")) + (cons :tag "Letter and Command" + (string :tag "Command letter") + (choice + (function) + (sexp)))))) + +(defcustom org-speed-command-hook + '(org-speed-command-activate org-babel-speed-command-activate) + "Hook for activating speed commands at strategic locations. +Hook functions are called in sequence until a valid handler is +found. + +Each hook takes a single argument, a user-pressed command key +which is also a `self-insert-command' from the global map. + +Within the hook, examine the cursor position and the command key +and return nil or a valid handler as appropriate. Handler could +be one of an interactive command, a function, or a form. + +Set `org-use-speed-commands' to non-nil value to enable this +hook. The default setting is `org-speed-command-activate'." + :group 'org-structure + :version "24.1" + :type 'hook) + +(defconst org-speed-commands-default + '(("Outline Navigation") + ("n" . (org-speed-move-safe 'org-next-visible-heading)) + ("p" . (org-speed-move-safe 'org-previous-visible-heading)) + ("f" . (org-speed-move-safe 'org-forward-heading-same-level)) + ("b" . (org-speed-move-safe 'org-backward-heading-same-level)) + ("F" . org-next-block) + ("B" . org-previous-block) + ("u" . (org-speed-move-safe 'outline-up-heading)) + ("j" . org-goto) + ("g" . (org-refile t)) + ("Outline Visibility") + ("c" . org-cycle) + ("C" . org-shifttab) + (" " . org-display-outline-path) + ("s" . org-toggle-narrow-to-subtree) + ("k" . org-cut-subtree) + ("=" . org-columns) + ("Outline Structure Editing") + ("U" . org-metaup) + ("D" . org-metadown) + ("r" . org-metaright) + ("l" . org-metaleft) + ("R" . org-shiftmetaright) + ("L" . org-shiftmetaleft) + ("i" . (progn (forward-char 1) (call-interactively + 'org-insert-heading-respect-content))) + ("^" . org-sort) + ("w" . org-refile) + ("a" . org-archive-subtree-default-with-confirmation) + ("@" . org-mark-subtree) + ("#" . org-toggle-comment) + ("Clock Commands") + ("I" . org-clock-in) + ("O" . org-clock-out) + ("Meta Data Editing") + ("t" . org-todo) + ("," . (org-priority)) + ("0" . (org-priority ?\ )) + ("1" . (org-priority ?A)) + ("2" . (org-priority ?B)) + ("3" . (org-priority ?C)) + (":" . org-set-tags-command) + ("e" . org-set-effort) + ("E" . org-inc-effort) + ("W" . (lambda(m) (interactive "sMinutes before warning: ") + (org-entry-put (point) "APPT_WARNTIME" m))) + ("Agenda Views etc") + ("v" . org-agenda) + ("/" . org-sparse-tree) + ("Misc") + ("o" . org-open-at-point) + ("?" . org-speed-command-help) + ("<" . (org-agenda-set-restriction-lock 'subtree)) + (">" . (org-agenda-remove-restriction-lock))) + "The default speed commands.") + +(defun org-print-speed-command (e) + (if (> (length (car e)) 1) + (progn + (princ "\n") + (princ (car e)) + (princ "\n") + (princ (make-string (length (car e)) ?-)) + (princ "\n")) + (princ (car e)) + (princ " ") + (if (symbolp (cdr e)) + (princ (symbol-name (cdr e))) + (prin1 (cdr e))) + (princ "\n"))) + +(defun org-speed-command-help () + "Show the available speed commands." + (interactive) + (unless org-use-speed-commands + (user-error "Speed commands are not activated, customize `org-use-speed-commands'")) + (with-output-to-temp-buffer "*Help*" + (princ "User-defined Speed commands\n===========================\n") + (mapc #'org-print-speed-command org-speed-commands-user) + (princ "\n") + (princ "Built-in Speed commands\n=======================\n") + (mapc #'org-print-speed-command org-speed-commands-default)) + (with-current-buffer "*Help*" + (setq truncate-lines t))) + +(defun org-speed-move-safe (cmd) + "Execute CMD, but make sure that the cursor always ends up in a headline. +If not, return to the original position and throw an error." + (interactive) + (let ((pos (point))) + (call-interactively cmd) + (unless (and (bolp) (org-at-heading-p)) + (goto-char pos) + (error "Boundary reached while executing %s" cmd)))) + +(defun org-speed-command-activate (keys) + "Hook for activating single-letter speed commands. +`org-speed-commands-default' specifies a minimal command set. +Use `org-speed-commands-user' for further customization." + (when (or (and (bolp) (looking-at org-outline-regexp)) + (and (functionp org-use-speed-commands) + (funcall org-use-speed-commands))) + (cdr (assoc keys (append org-speed-commands-user + org-speed-commands-default))))) + + +;;; Babel speed keys + +(defvar org-babel-key-prefix "\C-c\C-v" + "The key prefix for Babel interactive key-bindings. +See `org-babel-key-bindings' for the list of interactive Babel +functions which are assigned key bindings, and see +`org-babel-map' for the actual babel keymap.") + +(defvar org-babel-map (make-sparse-keymap) + "The keymap for interactive Babel functions.") + +(defvar org-babel-key-bindings + '(("p" . org-babel-previous-src-block) + ("\C-p" . org-babel-previous-src-block) + ("n" . org-babel-next-src-block) + ("\C-n" . org-babel-next-src-block) + ("e" . org-babel-execute-maybe) + ("\C-e" . org-babel-execute-maybe) + ("o" . org-babel-open-src-block-result) + ("\C-o" . org-babel-open-src-block-result) + ("\C-v" . org-babel-expand-src-block) + ("v" . org-babel-expand-src-block) + ("u" . org-babel-goto-src-block-head) + ("\C-u" . org-babel-goto-src-block-head) + ("g" . org-babel-goto-named-src-block) + ("r" . org-babel-goto-named-result) + ("\C-r" . org-babel-goto-named-result) + ("\C-b" . org-babel-execute-buffer) + ("b" . org-babel-execute-buffer) + ("\C-s" . org-babel-execute-subtree) + ("s" . org-babel-execute-subtree) + ("\C-d" . org-babel-demarcate-block) + ("d" . org-babel-demarcate-block) + ("\C-t" . org-babel-tangle) + ("t" . org-babel-tangle) + ("\C-f" . org-babel-tangle-file) + ("f" . org-babel-tangle-file) + ("\C-c" . org-babel-check-src-block) + ("c" . org-babel-check-src-block) + ("\C-j" . org-babel-insert-header-arg) + ("j" . org-babel-insert-header-arg) + ("\C-l" . org-babel-load-in-session) + ("l" . org-babel-load-in-session) + ("\C-i" . org-babel-lob-ingest) + ("i" . org-babel-lob-ingest) + ("\C-I" . org-babel-view-src-block-info) + ("I" . org-babel-view-src-block-info) + ("\C-z" . org-babel-switch-to-session) + ("z" . org-babel-switch-to-session-with-code) + ("\C-a" . org-babel-sha1-hash) + ("a" . org-babel-sha1-hash) + ("h" . org-babel-describe-bindings) + ("\C-x" . org-babel-do-key-sequence-in-edit-buffer) + ("x" . org-babel-do-key-sequence-in-edit-buffer) + ("k" . org-babel-remove-result-one-or-many) + ("\C-\M-h" . org-babel-mark-block)) + "Alist of key bindings and interactive Babel functions. +This list associates interactive Babel functions +with keys. Each element of this list will add an entry to the +`org-babel-map' using the letter key which is the `car' of the +a-list placed behind the generic `org-babel-key-prefix'.") + +(define-key org-mode-map org-babel-key-prefix org-babel-map) +(pcase-dolist (`(,key . ,def) org-babel-key-bindings) + (define-key org-babel-map key def)) + +(defun org-babel-speed-command-activate (keys) + "Hook for activating single-letter code block commands." + (when (and (bolp) + (let ((case-fold-search t)) (looking-at "[ \t]*#\\+begin_src")) + (eq 'src-block (org-element-type (org-element-at-point)))) + (cdr (assoc keys org-babel-key-bindings)))) + +;;;###autoload +(defun org-babel-describe-bindings () + "Describe all keybindings behind `org-babel-key-prefix'." + (interactive) + (describe-bindings org-babel-key-prefix)) + + +(provide 'org-keys) +;;; org-keys.el ends here diff --git a/lisp/org/org-lint.el b/lisp/org/org-lint.el index f9153358620..5b959db71a1 100644 --- a/lisp/org/org-lint.el +++ b/lisp/org/org-lint.el @@ -69,13 +69,13 @@ ;; - duplicate footnote definitions ;; - orphaned affiliated keywords ;; - obsolete affiliated keywords -;; - missing language in src blocks +;; - missing language in source blocks ;; - missing back-end in export blocks ;; - invalid Babel call blocks ;; - NAME values with a colon ;; - deprecated export block syntax ;; - deprecated Babel header properties -;; - wrong header arguments in src blocks +;; - wrong header arguments in source blocks ;; - misuse of CATEGORY keyword ;; - "coderef" links with unknown destination ;; - "custom-id" links with unknown destination @@ -100,16 +100,16 @@ ;; - indented diary-sexps ;; - obsolete QUOTE section ;; - obsolete "file+application" link -;; - blank headlines with tags +;; - spurious colons in tags ;;; Code: (require 'cl-lib) -(require 'org-element) +(require 'ob) +(require 'ol) (require 'org-macro) (require 'ox) -(require 'ob) ;;; Checkers @@ -162,7 +162,7 @@ :trust 'low) (make-org-lint-checker :name 'missing-language-in-src-block - :description "Report missing language in src blocks" + :description "Report missing language in source blocks" :categories '(babel)) (make-org-lint-checker :name 'missing-backend-in-export-block @@ -288,10 +288,14 @@ :description "Report obsolete \"file+application\" link" :categories '(link obsolete)) (make-org-lint-checker - :name 'empty-headline-with-tags - :description "Report ambiguous empty headlines with tags" - :categories '(headline) - :trust 'low)) + :name 'percent-encoding-link-escape + :description "Report obsolete escape syntax in links" + :categories '(link obsolete) + :trust 'low) + (make-org-lint-checker + :name 'spurious-colons + :description "Report spurious colons in tags" + :categories '(tags))) "List of all available checkers.") (defun org-lint--collect-duplicates @@ -560,8 +564,8 @@ Use :header-args: instead" (defun org-lint-link-to-local-file (ast) (org-element-map ast 'link (lambda (l) - (when (equal (org-element-property :type l) "file") - (let ((file (org-link-unescape (org-element-property :path l)))) + (when (equal "file" (org-element-property :type l)) + (let ((file (org-element-property :path l))) (and (not (file-remote-p file)) (not (file-exists-p file)) (list (org-element-property :begin l) @@ -576,12 +580,13 @@ Use :header-args: instead" (lambda (k) (when (equal (org-element-property :key k) "SETUPFILE") (let ((file (org-unbracket-string - "\"" "\"" - (org-element-property :value k)))) - (and (not (file-remote-p file)) + "\"" "\"" + (org-element-property :value k)))) + (and (not (org-file-url-p file)) + (not (file-remote-p file)) (not (file-exists-p file)) (list (org-element-property :begin k) - (format "Non-existent setup file \"%s\"" file)))))))) + (format "Non-existent setup file %S" file)))))))) (defun org-lint-wrong-include-link-parameter (ast) (org-element-map ast 'keyword @@ -591,7 +596,7 @@ Use :header-args: instead" (path (and (string-match "^\\(\".+\"\\|\\S-+\\)[ \t]*" value) (save-match-data - (org-unbracket-string "\"" "\"" (match-string 1 value)))))) + (org-strip-quotes (match-string 1 value)))))) (if (not path) (list (org-element-property :post-affiliated k) "Missing location argument in INCLUDE keyword") @@ -608,14 +613,13 @@ Use :header-args: instead" "Non-existent file argument in INCLUDE keyword") (let* ((visiting (if file (find-buffer-visiting file) (current-buffer))) - (buffer (or visiting (find-file-noselect file)))) + (buffer (or visiting (find-file-noselect file))) + (org-link-search-must-match-exact-headline t)) (unwind-protect (with-current-buffer buffer (when (and search - (not - (ignore-errors - (let ((org-link-search-inhibit-query t)) - (org-link-search search nil t))))) + (not (ignore-errors + (org-link-search search nil t)))) (list (org-element-property :post-affiliated k) (format "Invalid search part \"%s\" in INCLUDE keyword" @@ -886,6 +890,23 @@ Use \"export %s\" instead" (list (org-element-property :begin l) (format "Deprecated \"file+%s\" link type" app))))))) +(defun org-lint-percent-encoding-link-escape (ast) + (org-element-map ast 'link + (lambda (l) + (when (eq 'bracket (org-element-property :format l)) + (let* ((uri (org-element-property :path l)) + (start 0) + (obsolete-flag + (catch :obsolete + (while (string-match "%\\(..\\)?" uri start) + (setq start (match-end 0)) + (unless (member (match-string 1 uri) '("25" "5B" "5D" "20")) + (throw :obsolete nil))) + (string-match-p "%" uri)))) + (when obsolete-flag + (list (org-element-property :begin l) + "Link escaped with obsolete percent-encoding syntax"))))))) + (defun org-lint-wrong-header-argument (ast) (let* ((reports) (verify @@ -1037,14 +1058,13 @@ Use \"export %s\" instead" reports)))))))))))) reports)) -(defun org-lint-empty-headline-with-tags (ast) +(defun org-lint-spurious-colons (ast) (org-element-map ast '(headline inlinetask) (lambda (h) - (let ((title (org-element-property :raw-value h))) - (and (string-match-p "\\`:[[:alnum:]_@#%:]+:\\'" title) - (list (org-element-property :begin h) - (format "Headline containing only tags is ambiguous: %S" - title))))))) + (when (member "" (org-element-property :tags h)) + (list (org-element-property :begin h) + "Tags contain a spurious colon"))))) + ;;; Reports UI diff --git a/lisp/org/org-list.el b/lisp/org/org-list.el index 22692d224a8..c4aef32fc08 100644 --- a/lisp/org/org-list.el +++ b/lisp/org/org-list.el @@ -91,6 +91,7 @@ (defvar org-drawer-regexp) (defvar org-element-all-objects) (defvar org-inhibit-startup) +(defvar org-loop-over-headlines-in-active-region) (defvar org-odd-levels-only) (defvar org-outline-regexp-bol) (defvar org-scheduled-string) @@ -101,43 +102,31 @@ (declare-function org-at-heading-p "org" (&optional invisible-ok)) (declare-function org-back-to-heading "org" (&optional invisible-ok)) (declare-function org-before-first-heading-p "org" ()) -(declare-function org-combine-plists "org" (&rest plists)) (declare-function org-current-level "org" ()) (declare-function org-element-at-point "org-element" ()) (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" (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-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)) (declare-function org-element-property "org-element" (property element)) -(declare-function org-element-put-property "org-element" - (element property value)) +(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-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)) +(declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) (declare-function org-export-create-backend "ox" (&rest rest) t) (declare-function org-export-data-with-backend "ox" (data backend info)) (declare-function org-export-get-backend "ox" (name)) -(declare-function org-export-get-environment "ox" - (&optional backend subtreep ext-plist)) -(declare-function org-export-get-next-element "ox" - (blob info &optional n)) -(declare-function org-export-with-backend "ox" - (backend data &optional contents info)) +(declare-function org-export-get-environment "ox" (&optional backend subtreep ext-plist)) +(declare-function org-export-get-next-element "ox" (blob info &optional n)) +(declare-function org-export-with-backend "ox" (backend data &optional contents info)) (declare-function org-fix-tags-on-the-fly "org" ()) -(declare-function org-get-indentation "org" (&optional line)) (declare-function org-get-todo-state "org" ()) (declare-function org-in-block-p "org" (names)) -(declare-function org-in-regexp "org" (re &optional nlines visually)) (declare-function org-inlinetask-goto-beginning "org-inlinetask" ()) (declare-function org-inlinetask-goto-end "org-inlinetask" ()) (declare-function org-inlinetask-in-task-p "org-inlinetask" ()) @@ -147,16 +136,12 @@ (declare-function org-outline-level "org" ()) (declare-function org-previous-line-empty-p "org" ()) (declare-function org-reduced-level "org" (L)) -(declare-function org-remove-indentation "org" (code &optional n)) +(declare-function org-set-tags "org" (tags)) (declare-function org-show-subtree "org" ()) (declare-function org-sort-remove-invisible "org" (S)) (declare-function org-time-string-to-seconds "org" (s)) (declare-function org-timer-hms-to-secs "org-timer" (hms)) (declare-function org-timer-item "org-timer" (&optional arg)) -(declare-function org-trim "org" (s &optional keep-lead)) -(declare-function org-uniquify "org" (list)) -(declare-function org-invisible-p "org" (&optional pos)) -(declare-function outline-flag-region "outline" (from to flag)) (declare-function outline-next-heading "outline" ()) (declare-function outline-previous-heading "outline" ()) @@ -343,13 +328,6 @@ with the word \"recursive\" in the value." :group 'org-plain-lists :type 'boolean) -(defcustom org-list-description-max-indent 20 - "Maximum indentation for the second line of a description list. -When the indentation would be larger than this, it will become -5 characters instead." - :group 'org-plain-lists - :type 'integer) - (defcustom org-list-indent-offset 0 "Additional indentation for sub-items in a list. By setting this to a small number, usually 1 or 2, one can more @@ -358,45 +336,10 @@ clearly distinguish sub-items in a list." :version "24.1" :type 'integer) -(defcustom org-list-radio-list-templates - '((latex-mode "% BEGIN RECEIVE ORGLST %n -% END RECEIVE ORGLST %n -\\begin{comment} -#+ORGLST: SEND %n org-list-to-latex -- -\\end{comment}\n") - (texinfo-mode "@c BEGIN RECEIVE ORGLST %n -@c END RECEIVE ORGLST %n -@ignore -#+ORGLST: SEND %n org-list-to-texinfo -- -@end ignore\n") - (html-mode "<!-- BEGIN RECEIVE ORGLST %n --> -<!-- END RECEIVE ORGLST %n --> -<!-- -#+ORGLST: SEND %n org-list-to-html -- --->\n")) - "Templates for radio lists in different major modes. -All occurrences of %n in a template will be replaced with the name of the -list, obtained by prompting the user." - :group 'org-plain-lists - :type '(repeat - (list (symbol :tag "Major mode") - (string :tag "Format")))) - (defvar org-list-forbidden-blocks '("example" "verse" "src" "export") "Names of blocks where lists are not allowed. Names must be in lower case.") -(defvar org-list-export-context '(block inlinetask) - "Context types where lists will be interpreted during export. - -Valid types are `drawer', `inlinetask' and `block'. More -specifically, type `block' is determined by the variable -`org-list-forbidden-blocks'.") - - ;;; Predicates and regexps @@ -462,7 +405,7 @@ group 4: description tag") (ind-ref (if (or (looking-at "^[ \t]*$") (and inlinetask-re (looking-at inlinetask-re))) 10000 - (org-get-indentation)))) + (current-indentation)))) (cond ((eq (nth 2 context) 'invalid) nil) ((looking-at item-re) (point)) @@ -484,7 +427,7 @@ group 4: description tag") ;; Look for an item, less indented that reference line. (catch 'exit (while t - (let ((ind (org-get-indentation))) + (let ((ind (current-indentation))) (cond ;; This is exactly what we want. ((and (looking-at item-re) (< ind ind-ref)) @@ -654,7 +597,7 @@ Assume point is at an item." (item-re (org-item-re)) (inlinetask-re (and (featurep 'org-inlinetask) (org-inlinetask-outline-regexp))) - (beg-cell (cons (point) (org-get-indentation))) + (beg-cell (cons (point) (current-indentation))) itm-lst itm-lst-2 end-lst end-lst-2 struct (assoc-at-point (function @@ -682,7 +625,7 @@ Assume point is at an item." (save-excursion (catch 'exit (while t - (let ((ind (org-get-indentation))) + (let ((ind (current-indentation))) (cond ((<= (point) lim-up) ;; At upward limit: if we ended at an item, store it, @@ -742,7 +685,7 @@ Assume point is at an item." ;; position of items in END-LST-2. (catch 'exit (while t - (let ((ind (org-get-indentation))) + (let ((ind (current-indentation))) (cond ((>= (point) lim-down) ;; At downward limit: this is de facto the end of the @@ -861,6 +804,17 @@ This function modifies STRUCT." (t (cons pos (cdar ind-to-ori)))))) (cdr struct))))) +(defun org-list--delete-metadata () + "Delete metadata from the heading at point. +Metadata are tags, planning information and properties drawers." + (save-match-data + (org-with-wide-buffer + (org-set-tags nil) + (delete-region (line-beginning-position 2) + (save-excursion + (org-end-of-meta-data) + (org-skip-whitespace) + (if (eobp) (point) (line-beginning-position))))))) ;;; Accessors @@ -1281,10 +1235,18 @@ function ends. This function modifies STRUCT." (let ((case-fold-search t)) - ;; 1. Get information about list: position of point with regards - ;; to item start (BEFOREP), blank lines number separating items - ;; (BLANK-NB), if we're allowed to (SPLIT-LINE-P). - (let* ((item (progn (goto-char pos) (goto-char (org-list-get-item-begin)))) + ;; 1. Get information about list: ITEM containing POS, position of + ;; point with regards to item start (BEFOREP), blank lines + ;; number separating items (BLANK-NB), if we're allowed to + ;; (SPLIT-LINE-P). + (let* ((item (goto-char (catch :exit + (let ((inner-item 0)) + (pcase-dolist (`(,i . ,_) struct) + (cond + ((= i pos) (throw :exit i)) + ((< i pos) (setq inner-item i)) + (t (throw :exit inner-item)))) + inner-item)))) (item-end (org-list-get-item-end item struct)) (item-end-no-blank (org-list-get-item-end-before-blank item struct)) (beforep @@ -1497,8 +1459,8 @@ This function returns, destructively, the new list structure." (org-M-RET-may-split-line nil) ;; Store inner overlays (to preserve visibility). (overlays (cl-remove-if (lambda (o) (or (< (overlay-start o) item) - (> (overlay-end o) item))) - (overlays-in item item-end)))) + (> (overlay-end o) item))) + (overlays-in item item-end)))) (cond ((eq dest 'delete) (org-list-delete-item item struct)) ((eq dest 'kill) @@ -1590,23 +1552,6 @@ STRUCT may be modified if `org-list-demote-modify-bullet' matches bullets between START and END." (let* (acc (set-assoc (lambda (cell) (push cell acc) cell)) - (change-bullet-maybe - (function - (lambda (item) - (let ((new-bul-p - (cdr (assoc - ;; Normalize ordered bullets. - (let ((bul (org-trim - (org-list-get-bullet item struct)))) - (cond ((string-match "[A-Z]\\." bul) "A.") - ((string-match "[A-Z])" bul) "A)") - ((string-match "[a-z]\\." bul) "a.") - ((string-match "[a-z])" bul) "a)") - ((string-match "[0-9]\\." bul) "1.") - ((string-match "[0-9])" bul) "1)") - (t bul))) - org-list-demote-modify-bullet)))) - (when new-bul-p (org-list-set-bullet item struct new-bul-p)))))) (ind (lambda (cell) (let* ((item (car cell)) @@ -1622,11 +1567,24 @@ bullets between START and END." ;; Item is in zone... (let ((prev (org-list-get-prev-item item struct prevs))) ;; Check if bullet needs to be changed. - (funcall change-bullet-maybe item) + (pcase (assoc (let ((b (org-list-get-bullet item struct)) + (case-fold-search nil)) + (cond ((string-match "[A-Z]\\." b) "A.") + ((string-match "[A-Z])" b) "A)") + ((string-match "[a-z]\\." b) "a.") + ((string-match "[a-z])" b) "a)") + ((string-match "[0-9]\\." b) "1.") + ((string-match "[0-9])" b) "1)") + (t (org-trim b)))) + org-list-demote-modify-bullet) + (`(,_ . ,bullet) + (org-list-set-bullet + item struct (org-list-bullet-string bullet))) + (_ nil)) (cond ;; First item indented but not parent: error - ((and (not prev) (< parent start)) - (error "Cannot indent the first item of a list")) + ((and (not prev) (or (not parent) (< parent start))) + (user-error "Cannot indent the first item of a list")) ;; First item and parent indented: keep same ;; parent. ((not prev) (funcall set-assoc cell)) @@ -1899,7 +1857,7 @@ Initial position of cursor is restored after the changes." (org-inlinetask-goto-beginning)) ;; Shift only non-empty lines. ((looking-at-p "^[ \t]*\\S-") - (indent-line-to (+ (org-get-indentation) delta)))) + (indent-line-to (+ (current-indentation) delta)))) (forward-line -1))))) (modify-item (function @@ -1908,7 +1866,7 @@ Initial position of cursor is restored after the changes." (lambda (item) (goto-char item) (let* ((new-ind (org-list-get-ind item struct)) - (old-ind (org-get-indentation)) + (old-ind (current-indentation)) (new-bul (org-list-bullet-string (org-list-get-bullet item struct))) (old-bul (org-list-get-bullet item old-struct)) @@ -1983,7 +1941,7 @@ Initial position of cursor is restored after the changes." ;; Ignore empty lines. Also ignore blocks and ;; drawers contents. (unless (looking-at-p "[ \t]*$") - (setq min-ind (min (org-get-indentation) min-ind)) + (setq min-ind (min (current-indentation) min-ind)) (cond ((and (looking-at "#\\+BEGIN\\(:\\|_\\S-+\\)") (re-search-forward @@ -2037,7 +1995,9 @@ doesn't correspond anymore to the real list in buffer." ;; 5. Eventually fix checkboxes. (org-list-struct-fix-box struct parents prevs)) ;; 6. Apply structure modifications to buffer. - (org-list-struct-apply-struct struct old-struct))) + (org-list-struct-apply-struct struct old-struct)) + ;; 7. Return the updated structure + struct) @@ -2078,8 +2038,8 @@ Possible values are: `folded', `children' or `subtree'. See ((eq view 'folded) (let ((item-end (org-list-get-item-end-before-blank item struct))) ;; Hide from eol - (outline-flag-region (save-excursion (goto-char item) (point-at-eol)) - item-end t))) + (org-flag-region (save-excursion (goto-char item) (line-end-position)) + item-end t 'outline))) ((eq view 'children) ;; First show everything. (org-list-set-item-visibility item struct 'subtree) @@ -2092,31 +2052,19 @@ Possible values are: `folded', `children' or `subtree'. See ((eq view 'subtree) ;; Show everything (let ((item-end (org-list-get-item-end item struct))) - (outline-flag-region item item-end nil))))) + (org-flag-region item item-end nil 'outline))))) (defun org-list-item-body-column (item) "Return column at which body of ITEM should start." (save-excursion (goto-char item) - (if (save-excursion - (end-of-line) - (re-search-backward - "[ \t]::\\([ \t]\\|$\\)" (line-beginning-position) t)) - ;; Descriptive list item. Body starts after item's tag, if - ;; possible. - (let ((start (1+ (- (match-beginning 1) (line-beginning-position)))) - (ind (org-get-indentation))) - (if (> start (+ ind org-list-description-max-indent)) - (+ ind 5) - start)) - ;; Regular item. Body starts after bullet. - (looking-at "[ \t]*\\(\\S-+\\)") - (+ (progn (goto-char (match-end 1)) (current-column)) - (if (and org-list-two-spaces-after-bullet-regexp - (string-match-p org-list-two-spaces-after-bullet-regexp - (match-string 1))) - 2 - 1))))) + (looking-at "[ \t]*\\(\\S-+\\)") + (+ (progn (goto-char (match-end 1)) (current-column)) + (if (and org-list-two-spaces-after-bullet-regexp + (string-match-p org-list-two-spaces-after-bullet-regexp + (match-string 1))) + 2 + 1)))) @@ -2280,7 +2228,7 @@ item is invisible." (string-match "[.)]" (match-string 1)))) (match-beginning 4) (match-end 0))) - (if desc (backward-char 1)) + (when desc (backward-char 1)) t))))) (defun org-list-repair () @@ -2707,11 +2655,12 @@ Return t if successful." (error "Cannot outdent an item without its children")) ;; Normal shifting (t - (let* ((new-parents + (let* ((old-struct (copy-tree struct)) + (new-parents (if (< arg 0) (org-list-struct-outdent beg end struct parents) (org-list-struct-indent beg end struct parents prevs)))) - (org-list-write-struct struct new-parents)) + (org-list-write-struct struct new-parents old-struct)) (org-update-checkbox-count-maybe)))))) t) @@ -2840,7 +2789,8 @@ Sorting can be alphabetically, numerically, by date/time as given by a time stamp, by a property or by priority. Comparing entries ignores case by default. However, with an -optional argument WITH-CASE, the sorting considers case as well. +optional argument WITH-CASE, the sorting considers case as well, +if the current locale allows for it. The command prompts for the sorting type unless it has been given to the function through the SORTING-TYPE argument, which needs to @@ -2886,7 +2836,7 @@ function is being called interactively." (error "Missing key extractor")))) (sort-func (cond - ((= dcst ?a) #'string<) + ((= dcst ?a) #'org-string-collate-lessp) ((= dcst ?f) (or compare-func (and interactive? @@ -2977,7 +2927,7 @@ With a prefix argument ARG, change the region in a single item." (save-excursion (catch 'exit (while (< (point) end) - (let ((i (org-get-indentation))) + (let ((i (current-indentation))) (cond ;; Skip blank lines and inline tasks. ((looking-at "^[ \t]*$")) @@ -2993,7 +2943,7 @@ With a prefix argument ARG, change the region in a single item." (while (< (point) end) (unless (or (looking-at "^[ \t]*$") (looking-at org-outline-regexp-bol)) - (indent-line-to (+ (org-get-indentation) delta))) + (indent-line-to (+ (current-indentation) delta))) (forward-line)))))) (skip-blanks (lambda (pos) @@ -3027,6 +2977,9 @@ With a prefix argument ARG, change the region in a single item." (forward-line))) ;; Case 2. Start at an heading: convert to items. ((org-at-heading-p) + ;; Remove metadata + (let (org-loop-over-headlines-in-active-region) + (org-list--delete-metadata)) (let* ((bul (org-list-bullet-string "-")) (bul-len (length bul)) ;; Indentation of the first heading. It should be @@ -3047,6 +3000,9 @@ With a prefix argument ARG, change the region in a single item." ;; one, set it as reference, in order to preserve ;; subtrees. (when (< level ref-level) (setq ref-level level)) + ;; Remove metadata + (let (org-loop-over-headlines-in-active-region) + (org-list--delete-metadata)) ;; Remove stars and TODO keyword. (let ((case-fold-search nil)) (looking-at org-todo-line-regexp)) (delete-region (point) (or (match-beginning 3) @@ -3079,7 +3035,7 @@ With a prefix argument ARG, change the region in a single item." ;; set them as item's body. (arg (let* ((bul (org-list-bullet-string "-")) (bul-len (length bul)) - (ref-ind (org-get-indentation))) + (ref-ind (current-indentation))) (skip-chars-forward " \t") (insert bul) (forward-line) @@ -3195,80 +3151,14 @@ Point is left at list's end." (defun org-list-make-subtree () "Convert the plain list at point into a subtree." (interactive) - (if (not (ignore-errors (goto-char (org-in-item-p)))) - (error "Not in a list") - (let ((list (save-excursion (org-list-to-lisp t)))) - (insert (org-list-to-subtree list))))) - -(defun org-list-insert-radio-list () - "Insert a radio list template appropriate for this major mode." - (interactive) - (let* ((e (cl-assoc-if #'derived-mode-p org-list-radio-list-templates)) - (txt (nth 1 e)) - name pos) - (unless e (error "No radio list setup defined for %s" major-mode)) - (setq name (read-string "List name: ")) - (while (string-match "%n" txt) - (setq txt (replace-match name t t txt))) - (or (bolp) (insert "\n")) - (setq pos (point)) - (insert txt) - (goto-char pos))) - -(defun org-list-send-list (&optional maybe) - "Send a transformed version of this list to the receiver position. -With argument MAYBE, fail quietly if no transformation is defined -for this list." - (interactive) - (catch 'exit - (unless (org-at-item-p) (error "Not at a list item")) - (save-excursion - (let ((case-fold-search t)) - (re-search-backward "^[ \t]*#\\+ORGLST:" nil t) - (unless (looking-at - "[ \t]*#\\+ORGLST:[ \t]+SEND[ \t]+\\(\\S-+\\)[ \t]+\\([^ \t\n]+\\)") - (if maybe (throw 'exit nil) - (error "Don't know how to transform this list"))))) - (let* ((name (regexp-quote (match-string 1))) - (transform (intern (match-string 2))) - (bottom-point - (save-excursion - (re-search-forward - "\\(\\\\end{comment}\\|@end ignore\\|-->\\)" nil t) - (match-beginning 0))) - (top-point - (progn - (re-search-backward "#\\+ORGLST" nil t) - (re-search-forward (org-item-beginning-re) bottom-point t) - (match-beginning 0))) - (plain-list (save-excursion - (goto-char top-point) - (org-list-to-lisp)))) - (unless (fboundp transform) - (error "No such transformation function %s" transform)) - (let ((txt (funcall transform plain-list))) - ;; Find the insertion(s) place(s). - (save-excursion - (goto-char (point-min)) - (let ((receiver-count 0) - (begin-re (format "BEGIN +RECEIVE +ORGLST +%s\\([ \t]\\|$\\)" - name)) - (end-re (format "END +RECEIVE +ORGLST +%s\\([ \t]\\|$\\)" - name))) - (while (re-search-forward begin-re nil t) - (cl-incf receiver-count) - (let ((beg (line-beginning-position 2))) - (unless (re-search-forward end-re nil t) - (user-error "Cannot find end of receiver location at %d" beg)) - (beginning-of-line) - (delete-region beg (point)) - (insert txt "\n"))) - (cond - ((> receiver-count 1) - (message "List converted and installed at receiver locations")) - ((= receiver-count 1) - (message "List converted and installed at receiver location")) - (t (user-error "No valid receiver location found"))))))))) + (let ((item (org-in-item-p))) + (unless item (error "Not in a list")) + (goto-char item) + (let ((level (pcase (org-current-level) + (`nil 1) + (l (1+ (org-reduced-level l))))) + (list (save-excursion (org-list-to-lisp t)))) + (insert (org-list-to-subtree list level) "\n")))) (defun org-list-to-generic (list params) "Convert a LIST parsed through `org-list-to-lisp' to a custom format. @@ -3577,21 +3467,22 @@ with overruling parameters for `org-list-to-generic'." :cbtrans "[-] "))) (org-list-to-generic list (org-combine-plists defaults params)))) -(defun org-list-to-subtree (list &optional params) +(defun org-list-to-subtree (list &optional start-level params) "Convert LIST into an Org subtree. -LIST is as returned by `org-list-to-lisp'. PARAMS is a property -list with overruling parameters for `org-list-to-generic'." +LIST is as returned by `org-list-to-lisp'. Subtree starts at +START-LEVEL or level 1 if nil. PARAMS is a property list with +overruling parameters for `org-list-to-generic'." (let* ((blank (pcase (cdr (assq 'heading org-blank-before-new-entry)) (`t t) (`auto (save-excursion (org-with-limited-levels (outline-previous-heading)) (org-previous-line-empty-p))))) - (level (org-reduced-level (or (org-current-level) 0))) + (level (or start-level 1)) (make-stars (lambda (_type depth &optional _count) ;; Return the string for the heading, depending on DEPTH ;; of current sub-list. - (let ((oddeven-level (+ level depth))) + (let ((oddeven-level (+ level (1- depth)))) (concat (make-string (if org-odd-levels-only (1- (* 2 oddeven-level)) oddeven-level) diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el index a151e1e8469..c928ea732c2 100644 --- a/lisp/org/org-macro.el +++ b/lisp/org/org-macro.el @@ -52,18 +52,24 @@ (declare-function org-element-at-point "org-element" ()) (declare-function org-element-context "org-element" (&optional element)) +(declare-function org-element-copy "org-element" (datum)) (declare-function org-element-macro-parser "org-element" ()) +(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-restriction "org-element" (element)) (declare-function org-element-type "org-element" (element)) +(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-file-url-p "org" (file)) (declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) +(declare-function org-link-search "ol" (s &optional avoid-pos stealth)) (declare-function org-mode "org" ()) -(declare-function org-trim "org" (s &optional keep-lead)) (declare-function vc-backend "vc-hooks" (f)) (declare-function vc-call "vc-hooks" (fun file &rest args) t) (declare-function vc-exec-after "vc-dispatcher" (code)) +(defvar org-link-search-must-match-exact-headline) + ;;; Variables (defvar-local org-macro-templates nil @@ -77,95 +83,100 @@ directly, use instead: ;;; Functions -(defun org-macro--collect-macros () +(defun org-macro--set-template (name value templates) + "Set template for the macro NAME. +VALUE is the template of the macro. The new value override the +previous one, unless VALUE is nil. TEMPLATES is the list of +templates. Return the updated list." + (when value + (let ((old-definition (assoc name templates))) + (if old-definition + (setcdr old-definition value) + (push (cons name value) templates)))) + templates) + +(defun org-macro--collect-macros (&optional files templates) "Collect macro definitions in current buffer and setup files. -Return an alist containing all macro templates found." - (letrec ((collect-macros - (lambda (files templates) - ;; Return an alist of macro templates. FILES is a list - ;; of setup files names read so far, used to avoid - ;; circular dependencies. TEMPLATES is the alist - ;; collected so far. - (let ((case-fold-search t)) - (org-with-wide-buffer - (goto-char (point-min)) - (while (re-search-forward - "^[ \t]*#\\+\\(MACRO\\|SETUPFILE\\):" nil t) - (let ((element (org-element-at-point))) - (when (eq (org-element-type element) 'keyword) - (let ((val (org-element-property :value element))) - (if (equal (org-element-property :key element) "MACRO") - ;; Install macro in TEMPLATES. - (when (string-match - "^\\(.*?\\)\\(?:\\s-+\\(.*\\)\\)?\\s-*$" val) - (let* ((name (match-string 1 val)) - (template (or (match-string 2 val) "")) - (old-cell (assoc name templates))) - (if old-cell (setcdr old-cell template) - (push (cons name template) templates)))) - ;; Enter setup file. - (let* ((uri (org-unbracket-string "\"" "\"" (org-trim val))) - (uri-is-url (org-file-url-p uri)) - (uri (if uri-is-url - uri - (expand-file-name uri)))) - ;; Avoid circular dependencies. - (unless (member uri files) - (with-temp-buffer - (unless uri-is-url - (setq default-directory - (file-name-directory uri))) - (org-mode) - (insert (org-file-contents uri 'noerror)) - (setq templates - (funcall collect-macros (cons uri files) - templates))))))))))) - templates)))) - (funcall collect-macros nil nil))) +Return an alist containing all macro templates found. + +FILES is a list of setup files names read so far, used to avoid +circular dependencies. TEMPLATES is the alist collected so far. +The two arguments are used in recursive calls." + (let ((case-fold-search t)) + (org-with-point-at 1 + (while (re-search-forward "^[ \t]*#\\+\\(MACRO\\|SETUPFILE\\):" nil t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'keyword) + (let ((val (org-element-property :value element))) + (if (equal "MACRO" (org-element-property :key element)) + ;; Install macro in TEMPLATES. + (when (string-match "^\\(\\S-+\\)[ \t]*" val) + (let ((name (match-string 1 val)) + (value (substring val (match-end 0)))) + (setq templates + (org-macro--set-template name value templates)))) + ;; Enter setup file. + (let* ((uri (org-strip-quotes val)) + (uri-is-url (org-file-url-p uri)) + (uri (if uri-is-url + uri + (expand-file-name uri)))) + ;; Avoid circular dependencies. + (unless (member uri files) + (with-temp-buffer + (unless uri-is-url + (setq default-directory (file-name-directory uri))) + (org-mode) + (insert (org-file-contents uri 'noerror)) + (setq templates + (org-macro--collect-macros + (cons uri files) templates))))))))))) + (let ((macros `(("author" . ,(org-macro--find-keyword-value "AUTHOR")) + ("email" . ,(org-macro--find-keyword-value "EMAIL")) + ("title" . ,(org-macro--find-keyword-value "TITLE" t)) + ("date" . ,(org-macro--find-date))))) + (pcase-dolist (`(,name . ,value) macros) + (setq templates (org-macro--set-template name value templates)))) + templates)) (defun org-macro-initialize-templates () "Collect macro templates defined in current buffer. + Templates are stored in buffer-local variable -`org-macro-templates'. In addition to buffer-defined macros, the -function installs the following ones: \"property\", -\"time\". and, if the buffer is associated to a file, -\"input-file\" and \"modification-time\"." - (let* ((templates nil) - (update-templates - (lambda (cell) - (let ((old-template (assoc (car cell) templates))) - (if old-template (setcdr old-template (cdr cell)) - (push cell templates)))))) - ;; Install "property", "time" macros. - (mapc update-templates - (list (cons "property" - "(eval (save-excursion - (let ((l \"$2\")) - (when (org-string-nw-p l) - (condition-case _ - (let ((org-link-search-must-match-exact-headline t)) - (org-link-search l nil t)) - (error - (error \"Macro property failed: cannot find location %s\" - l))))) - (org-entry-get nil \"$1\" 'selective)))") - (cons "time" "(eval (format-time-string \"$1\"))"))) - ;; Install "input-file", "modification-time" macros. - (let ((visited-file (buffer-file-name (buffer-base-buffer)))) - (when (and visited-file (file-exists-p visited-file)) - (mapc update-templates - (list (cons "input-file" (file-name-nondirectory visited-file)) - (cons "modification-time" - (format "(eval (format-time-string \"$1\" (or (and (org-string-nw-p \"$2\") (org-macro--vc-modified-time %s)) '%s)))" - (prin1-to-string visited-file) - (prin1-to-string - (file-attribute-modification-time - (file-attributes visited-file))))))))) - ;; Initialize and install "n" macro. - (org-macro--counter-initialize) - (funcall update-templates - (cons "n" "(eval (org-macro--counter-increment \"$1\" \"$2\"))")) - (setq org-macro-templates (nconc (org-macro--collect-macros) templates)))) +`org-macro-templates'. + +In addition to buffer-defined macros, the function installs the +following ones: \"n\", \"author\", \"email\", \"keyword\", +\"time\", \"property\", and, if the buffer is associated to +a file, \"input-file\" and \"modification-time\"." + (require 'org-element) + (org-macro--counter-initialize) ;for "n" macro + (setq org-macro-templates + (nconc + ;; Install user-defined macros. + (org-macro--collect-macros) + ;; Install file-specific macros. + (let ((visited-file (buffer-file-name (buffer-base-buffer)))) + (and visited-file + (file-exists-p visited-file) + (list + `("input-file" . ,(file-name-nondirectory visited-file)) + `("modification-time" . + ,(format "(eval +\(format-time-string $1 + (or (and (org-string-nw-p $2) + (org-macro--vc-modified-time %s)) + '%s)))" + (prin1-to-string visited-file) + (prin1-to-string + (file-attribute-modification-time + (file-attributes visited-file)))))))) + ;; Install generic macros. + (list + '("n" . "(eval (org-macro--counter-increment $1 $2))") + '("keyword" . "(eval (org-macro--find-keyword-value $1))") + '("time" . "(eval (format-time-string $1))") + '("property" . "(eval (org-macro--get-property $1 $2))"))))) (defun org-macro-expand (macro templates) "Return expanded MACRO, as a string. @@ -177,31 +188,35 @@ default value. Return nil if no template was found." ;; Macro names are case-insensitive. (cdr (assoc-string (org-element-property :key macro) templates t)))) (when template - (let ((value (replace-regexp-in-string - "\\$[0-9]+" - (lambda (arg) - (or (nth (1- (string-to-number (substring arg 1))) - (org-element-property :args macro)) - ;; No argument: remove place-holder. - "")) - template nil 'literal))) - ;; VALUE starts with "(eval": it is a s-exp, `eval' it. - (when (string-match "\\`(eval\\>" value) - (setq value (eval (read value)))) - ;; Return string. + (let* ((eval? (string-match-p "\\`(eval\\>" template)) + (value + (replace-regexp-in-string + "\\$[0-9]+" + (lambda (m) + (let ((arg (or (nth (1- (string-to-number (substring m 1))) + (org-element-property :args macro)) + ;; No argument: remove place-holder. + ""))) + ;; `eval' implies arguments are strings. + (if eval? (format "%S" arg) arg))) + template nil 'literal))) + (when eval? + (setq value (eval (condition-case nil (read value) + (error (debug)))))) + ;; Force return value to be a string. (format "%s" (or value "")))))) -(defun org-macro-replace-all (templates &optional finalize keywords) +(defun org-macro-replace-all (templates &optional keywords) "Replace all macros in current buffer by their expansion. TEMPLATES is an alist of templates used for expansion. See `org-macro-templates' for a buffer-local default value. -If optional arg FINALIZE is non-nil, raise an error if a macro is -found in the buffer with no definition in TEMPLATES. - Optional argument KEYWORDS, when non-nil is a list of keywords, -as strings, where macro expansion is allowed." +as strings, where macro expansion is allowed. + +Return an error if a macro in the buffer cannot be associated to +a definition in TEMPLATES." (org-with-wide-buffer (goto-char (point-min)) (let ((properties-regexp (format "\\`EXPORT_%s\\+?\\'" @@ -225,7 +240,8 @@ as strings, where macro expansion is allowed." (goto-char (match-beginning 0)) (org-element-macro-parser)))))) (when macro - (let* ((value (org-macro-expand macro templates)) + (let* ((key (org-element-property :key macro)) + (value (org-macro-expand macro templates)) (begin (org-element-property :begin macro)) (signature (list begin macro @@ -234,8 +250,7 @@ as strings, where macro expansion is allowed." ;; macro with the same arguments is expanded at the ;; same position twice. (cond ((member signature record) - (error "Circular macro expansion: %s" - (org-element-property :key macro))) + (error "Circular macro expansion: %s" key)) (value (push signature record) (delete-region @@ -247,7 +262,11 @@ as strings, where macro expansion is allowed." ;; Leave point before replacement in case of ;; recursive expansions. (save-excursion (insert value))) - (finalize + ;; Special "results" macro: if it is not defined, + ;; simply leave it as-is. It will be expanded in + ;; a second phase. + ((equal key "results")) + (t (error "Undefined Org macro: %s; aborting" (org-element-property :key macro)))))))))))) @@ -295,6 +314,53 @@ Return a list of arguments, as strings. This is the opposite of ;;; Helper functions and variables for internal macros +(defun org-macro--get-property (property location) + "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))) + +(defun org-macro--find-keyword-value (name &optional collect) + "Find value for keyword NAME in current buffer. +Return value associated to the keywords named after NAME, as +a string, or nil. When optional argument COLLECT is non-nil, +concatenate values, separated with a space, from various keywords +in the buffer." + (org-with-point-at 1 + (let ((regexp (format "^[ \t]*#\\+%s:" (regexp-quote name))) + (case-fold-search t) + (result nil)) + (catch :exit + (while (re-search-forward regexp nil t) + (let ((element (org-element-at-point))) + (when (eq 'keyword (org-element-type element)) + (let ((value (org-element-property :value element))) + (if (not collect) (throw :exit value) + (setq result (concat result " " value))))))) + (and result (org-trim result)))))) + +(defun org-macro--find-date () + "Find value for DATE in current buffer. +Return value as a string." + (let* ((value (org-macro--find-keyword-value "DATE")) + (date (org-element-parse-secondary-string + value (org-element-restriction 'keyword)))) + (if (and (consp date) + (not (cdr date)) + (eq 'timestamp (org-element-type (car date)))) + (format "(eval (if (org-string-nw-p $1) %s %S))" + (format "(org-timestamp-format '%S $1)" + (org-element-copy (car date))) + value) + value))) + (defun org-macro--vc-modified-time (file) (save-window-excursion (when (vc-backend file) @@ -313,7 +379,7 @@ Return a list of arguments, as strings. This is the opposite of (buffer-substring (point) (line-end-position))))) (when (cl-some #'identity time) - (setq date (encode-time time)))))))) + (setq date (apply #'encode-time time)))))))) (let ((proc (get-buffer-process buf))) (while (and proc (accept-process-output proc .5 nil t))))) (kill-buffer buf)) diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el index bb96a06165e..3cc681029e1 100644 --- a/lisp/org/org-macs.el +++ b/lisp/org/org-macs.el @@ -32,6 +32,14 @@ ;;; Code: (require 'cl-lib) +(require 'format-spec) + +(declare-function org-string-collate-lessp "org-compat" (s1 s2 &optional locale ignore-case)) + +(defvar org-ts-regexp0) + + +;;; Macros (defmacro org-with-gensyms (symbols &rest body) (declare (debug (sexp body)) (indent 1)) @@ -40,113 +48,8 @@ symbols) ,@body)) -(defun org-string-nw-p (s) - "Return S if S is a string containing a non-blank character. -Otherwise, return nil." - (and (stringp s) - (string-match-p "[^ \r\t\n]" s) - s)) - -(defun org-split-string (string &optional separators) - "Splits STRING into substrings at SEPARATORS. - -SEPARATORS is a regular expression. When nil, it defaults to -\"[ \f\t\n\r\v]+\". - -Unlike `split-string', matching SEPARATORS at the beginning and -end of string are ignored." - (let ((separators (or separators "[ \f\t\n\r\v]+"))) - (when (string-match (concat "\\`" separators) string) - (setq string (replace-match "" nil nil string))) - (when (string-match (concat separators "\\'") string) - (setq string (replace-match "" nil nil string))) - (split-string string separators))) - -(defun org-string-display (string) - "Return STRING as it is displayed in the current buffer. -This function takes into consideration `invisible' and `display' -text properties." - (let* ((build-from-parts - (lambda (s property filter) - ;; Build a new string out of string S. On every group of - ;; contiguous characters with the same PROPERTY value, - ;; call FILTER on the properties list at the beginning of - ;; the group. If it returns a string, replace the - ;; characters in the group with it. Otherwise, preserve - ;; those characters. - (let ((len (length s)) - (new "") - (i 0) - (cursor 0)) - (while (setq i (text-property-not-all i len property nil s)) - (let ((end (next-single-property-change i property s len)) - (value (funcall filter (text-properties-at i s)))) - (when value - (setq new (concat new (substring s cursor i) value)) - (setq cursor end)) - (setq i end))) - (concat new (substring s cursor))))) - (prune-invisible - (lambda (s) - (funcall build-from-parts s 'invisible - (lambda (props) - ;; If `invisible' property in PROPS means text - ;; is to be invisible, return the empty string. - ;; Otherwise return nil so that the part is - ;; skipped. - (and (or (eq t buffer-invisibility-spec) - (assoc-string (plist-get props 'invisible) - buffer-invisibility-spec)) - ""))))) - (replace-display - (lambda (s) - (funcall build-from-parts s 'display - (lambda (props) - ;; If there is any string specification in - ;; `display' property return it. Also attach - ;; other text properties on the part to that - ;; string (face...). - (let* ((display (plist-get props 'display)) - (value (if (stringp display) display - (cl-some #'stringp display)))) - (when value - (apply #'propertize - ;; Displayed string could contain - ;; invisible parts, but no nested - ;; display. - (funcall prune-invisible value) - 'display - (and (not (stringp display)) - (cl-remove-if #'stringp display)) - props)))))))) - ;; `display' property overrides `invisible' one. So we first - ;; replace characters with `display' property. Then we remove - ;; invisible characters. - (funcall prune-invisible (funcall replace-display string)))) - -(defun org-string-width (string) - "Return width of STRING when displayed in the current buffer. -Unlike `string-width', this function takes into consideration -`invisible' and `display' text properties." - (string-width (org-string-display string))) - -(defun org-not-nil (v) - "If V not nil, and also not the string \"nil\", then return V. -Otherwise return nil." - (and v (not (equal v "nil")) v)) - -(defmacro org-preserve-lc (&rest body) - (declare (debug (body))) - (org-with-gensyms (line col) - `(let ((,line (org-current-line)) - (,col (current-column))) - (unwind-protect - (progn ,@body) - (org-goto-line ,line) - (org-move-to-column ,col))))) - -;; Use `org-with-silent-modifications' to ignore cosmetic changes and -;; `org-unmodified' to ignore real text modifications +;; Use `with-silent-modifications' to ignore cosmetic changes and +;; `org-unmodified' to ignore real text modifications. (defmacro org-unmodified (&rest body) "Run BODY while preserving the buffer's `buffer-modified-p' state." (declare (debug (body))) @@ -176,7 +79,7 @@ Otherwise return nil." (org-with-gensyms (mpom) `(let ((,mpom ,pom)) (save-excursion - (if (markerp ,mpom) (set-buffer (marker-buffer ,mpom))) + (when (markerp ,mpom) (set-buffer (marker-buffer ,mpom))) (org-with-wide-buffer (goto-char (or ,mpom (point))) ,@body))))) @@ -211,107 +114,38 @@ Otherwise return nil." (declare (debug (body))) `(let ((inhibit-read-only t)) ,@body)) -(defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t - rear-nonsticky t mouse-map t fontified t - org-emphasis t) - "Properties to remove when a string without properties is wanted.") - -(defsubst org-no-properties (s &optional restricted) - "Remove all text properties from string S. -When RESTRICTED is non-nil, only remove the properties listed -in `org-rm-props'." - (if restricted (remove-text-properties 0 (length s) org-rm-props s) - (set-text-properties 0 (length s) nil s)) - s) - -(defsubst org-get-alist-option (option key) - (cond ((eq key t) t) - ((eq option t) t) - ((assoc key option) (cdr (assoc key option))) - (t (let ((r (cdr (assq 'default option)))) - (if (listp r) (delq nil r) r))))) - -(defsubst org-check-external-command (cmd &optional use no-error) - "Check if external program CMD for USE exists, error if not. -When the program does exist, return its path. -When it does not exist and NO-ERROR is set, return nil. -Otherwise, throw an error. The optional argument USE can describe what this -program is needed for, so that the error message can be more informative." - (or (executable-find cmd) - (if no-error - nil - (error "Can't find `%s'%s" cmd - (if use (format " (%s)" use) ""))))) - -(defsubst org-last (list) - "Return the last element of LIST." - (car (last list))) - -(defun org-let (list &rest body) - (eval (cons 'let (cons list body)))) -(put 'org-let 'lisp-indent-function 1) - -(defun org-let2 (list1 list2 &rest body) - (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body))))))) -(put 'org-let2 'lisp-indent-function 2) - -(defsubst org-call-with-arg (command arg) - "Call COMMAND interactively, but pretend prefix arg was ARG." - (let ((current-prefix-arg arg)) (call-interactively command))) - -(defsubst org-current-line (&optional pos) - (save-excursion - (and pos (goto-char pos)) - ;; works also in narrowed buffer, because we start at 1, not point-min - (+ (if (bolp) 1 0) (count-lines 1 (point))))) - -(defsubst org-goto-line (N) - (save-restriction - (widen) - (goto-char (point-min)) - (forward-line (1- N)))) - -(defsubst org-current-line-string (&optional to-here) - (buffer-substring (point-at-bol) (if to-here (point) (point-at-eol)))) - -(defsubst org-pos-in-match-range (pos n) - (and (match-beginning n) - (<= (match-beginning n) pos) - (>= (match-end n) pos))) - -(defun org-match-line (regexp) - "Match REGEXP at the beginning of the current line." - (save-excursion - (beginning-of-line) - (looking-at regexp))) - -(defun org-plist-delete (plist property) - "Delete PROPERTY from PLIST. -This is in contrast to merely setting it to 0." - (let (p) - (while plist - (if (not (eq property (car plist))) - (setq p (plist-put p (car plist) (nth 1 plist)))) - (setq plist (cddr plist))) - p)) - (defmacro org-save-outline-visibility (use-markers &rest body) "Save and restore outline visibility around BODY. -If USE-MARKERS is non-nil, use markers for the positions. -This means that the buffer may change while running BODY, -but it also means that the buffer should stay alive -during the operation, because otherwise all these markers will -point nowhere." +If USE-MARKERS is non-nil, use markers for the positions. This +means that the buffer may change while running BODY, but it also +means that the buffer should stay alive during the operation, +because otherwise all these markers will point to nowhere." (declare (debug (form body)) (indent 1)) - (org-with-gensyms (data) - `(let ((,data (org-outline-overlay-data ,use-markers))) - (unwind-protect - (prog1 (progn ,@body) - (org-set-outline-overlay-data ,data)) - (when ,use-markers - (dolist (c ,data) - (when (markerp (car c)) (move-marker (car c) nil)) - (when (markerp (cdr c)) (move-marker (cdr c) nil)))))))) + (org-with-gensyms (data invisible-types markers?) + `(let* ((,invisible-types '(org-hide-block org-hide-drawer outline)) + (,markers? ,use-markers) + (,data + (mapcar (lambda (o) + (let ((beg (overlay-start o)) + (end (overlay-end o)) + (type (overlay-get o 'invisible))) + (and beg end + (> end beg) + (memq type ,invisible-types) + (list (if ,markers? (copy-marker beg) beg) + (if ,markers? (copy-marker end t) end) + type)))) + (org-with-wide-buffer + (overlays-in (point-min) (point-max)))))) + (unwind-protect (progn ,@body) + (org-with-wide-buffer + (dolist (type ,invisible-types) + (remove-overlays (point-min) (point-max) 'invisible type)) + (pcase-dolist (`(,beg ,end ,type) (delq nil ,data)) + (org-flag-region beg end t type) + (when ,markers? + (set-marker beg nil) + (set-marker end nil)))))))) (defmacro org-with-wide-buffer (&rest body) "Execute body while temporarily widening the buffer." @@ -335,49 +169,190 @@ point nowhere." (org-outline-regexp-bol (concat "^" org-outline-regexp))) ,@body))) -(defvar org-outline-regexp) ; 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 () - "Return outline-regexp with limited number of levels. -The number of levels is controlled by `org-inlinetask-min-level'." - (cond ((not (derived-mode-p 'org-mode)) - outline-regexp) - ((not (featurep 'org-inlinetask)) - 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))))) - (defmacro org-eval-in-environment (environment form) (declare (debug (form form)) (indent 1)) `(eval (list 'let ,environment ',form))) -(defun org-make-parameter-alist (flat) - "Return alist based on FLAT. -FLAT is a list with alternating symbol names and values. The -returned alist is a list of lists with the symbol name in car and -the value in cdr." - (when flat - (cons (list (car flat) (cadr flat)) - (org-make-parameter-alist (cddr flat))))) - ;;;###autoload (defmacro org-load-noerror-mustsuffix (file) "Load FILE with optional arguments NOERROR and MUSTSUFFIX." `(load ,file 'noerror nil nil 'mustsuffix)) -(defun org-unbracket-string (pre post string) - "Remove PRE/POST from the beginning/end of STRING. -Both PRE and POST must be pre-/suffixes of STRING, or neither is -removed." - (if (and (string-prefix-p pre string) - (string-suffix-p post string)) - (substring string (length pre) (- (length post))) - string)) +(defmacro org-preserve-local-variables (&rest body) + "Execute BODY while preserving local variables." + (declare (debug (body))) + `(let ((local-variables + (org-with-wide-buffer + (goto-char (point-max)) + (let ((case-fold-search t)) + (and (re-search-backward "^[ \t]*# +Local Variables:" + (max (- (point) 3000) 1) + t) + (delete-and-extract-region (point) (point-max))))))) + (unwind-protect (progn ,@body) + (when local-variables + (org-with-wide-buffer + (goto-char (point-max)) + ;; If last section is folded, make sure to also hide file + ;; local variables after inserting them back. + (let ((overlay + (cl-find-if (lambda (o) + (eq 'outline (overlay-get o 'invisible))) + (overlays-at (1- (point)))))) + (unless (bolp) (insert "\n")) + (insert local-variables) + (when overlay + (move-overlay overlay (overlay-start overlay) (point-max))))))))) + +(defmacro org-no-popups (&rest body) + "Suppress popup windows and evaluate BODY." + `(let (pop-up-frames display-buffer-alist) + ,@body)) + + +;;; Buffer and windows + +(defun org-base-buffer (buffer) + "Return the base buffer of BUFFER, if it has one. Else return the buffer." + (when buffer + (or (buffer-base-buffer buffer) + buffer))) + +(defun org-find-base-buffer-visiting (file) + "Like `find-buffer-visiting' but always return the base buffer and +not an indirect buffer." + (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))) + +(defun org-fit-window-to-buffer (&optional window max-height min-height + shrink-only) + "Fit WINDOW to the buffer, but only if it is not a side-by-side window. +WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are +passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call +`shrink-window-if-larger-than-buffer' instead, the height limit is +ignored in this case." + (cond ((if (fboundp 'window-full-width-p) + (not (window-full-width-p window)) + ;; Do nothing if another window would suffer. + (> (frame-width) (window-width window)))) + ((and (fboundp 'fit-window-to-buffer) (not shrink-only)) + (fit-window-to-buffer window max-height min-height)) + ((fboundp 'shrink-window-if-larger-than-buffer) + (shrink-window-if-larger-than-buffer window))) + (or window (selected-window))) + + + +;;; File + +(defun org-file-newer-than-p (file time) + "Non-nil if FILE is newer than TIME. +FILE is a filename, as a string, TIME is a list of integers, as +returned by, e.g., `current-time'." + (and (file-exists-p file) + ;; Only compare times up to whole seconds as some file-systems + ;; (e.g. HFS+) do not retain any finer granularity. As + ;; a consequence, make sure we return non-nil when the two + ;; times are equal. + (not (time-less-p (cl-subseq (nth 5 (file-attributes file)) 0 2) + (cl-subseq time 0 2))))) + +(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)) + (out-dir (or (file-name-directory source) "./")) + (output (expand-file-name (concat base-name "." ext) out-dir)) + (time (current-time)) + (err-msg (if (stringp err-msg) (concat ". " err-msg) ""))) + (save-window-excursion + (pcase process + ((pred functionp) (funcall process (shell-quote-argument source))) + ((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 source)) + (?F . ,(shell-quote-argument full-name)) + (?o . ,(shell-quote-argument out-dir)) + (?O . ,(shell-quote-argument output)))))) + (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 + +(defun org-do-remove-indentation (&optional n) + "Remove the maximum common indentation from the buffer. +When optional argument N is a positive integer, remove exactly +that much characters from indentation, if possible. Return nil +if it fails." + (catch :exit + (goto-char (point-min)) + ;; Find maximum common indentation, if not specified. + (let ((n (or n + (let ((min-ind (point-max))) + (save-excursion + (while (re-search-forward "^[ \t]*\\S-" nil t) + (let ((ind (current-indentation))) + (if (zerop ind) (throw :exit nil) + (setq min-ind (min min-ind ind)))))) + min-ind)))) + (if (zerop n) (throw :exit nil) + ;; Remove exactly N indentation, but give up if not possible. + (while (not (eobp)) + (let ((ind (progn (skip-chars-forward " \t") (current-column)))) + (cond ((eolp) (delete-region (line-beginning-position) (point))) + ((< ind n) (throw :exit nil)) + (t (indent-line-to (- ind n)))) + (forward-line))) + ;; Signal success. + t)))) + + + +;;; Input (defun org-read-function (prompt &optional allow-empty?) "Prompt for a function. @@ -389,6 +364,191 @@ error when the user input is empty." (allow-empty? nil) (t (user-error "Empty input is not valid"))))) +(defun org-completing-read (&rest args) + "Completing-read with SPACE being a normal character." + (let ((enable-recursive-minibuffers t) + (minibuffer-local-completion-map + (copy-keymap minibuffer-local-completion-map))) + (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) + (apply #'completing-read args))) + +(defun org--mks-read-key (allowed-keys prompt) + "Read a key and ensure it is a member of ALLOWED-KEYS. +TAB, SPC and RET are treated equivalently." + (let* ((key (char-to-string + (pcase (read-char-exclusive prompt) + ((or ?\s ?\t ?\r) ?\t) + (char char))))) + (if (member key allowed-keys) + key + (message "Invalid key: `%s'" key) + (sit-for 1) + (org--mks-read-key allowed-keys prompt)))) + +(defun org-mks (table title &optional prompt specials) + "Select a member of an alist with multiple keys. + +TABLE is the alist which should contain entries where the car is a string. +There should be two types of entries. + +1. prefix descriptions like (\"a\" \"Description\") + This indicates that `a' is a prefix key for multi-letter selection, and + that there are entries following with keys like \"ab\", \"ax\"... + +2. Select-able members must have more than two elements, with the first + being the string of keys that lead to selecting it, and the second a + short description string of the item. + +The command will then make a temporary buffer listing all entries +that can be selected with a single key, and all the single key +prefixes. When you press the key for a single-letter entry, it is selected. +When you press a prefix key, the commands (and maybe further prefixes) +under this key will be shown and offered for selection. + +TITLE will be placed over the selection in the temporary buffer, +PROMPT will be used when prompting for a key. SPECIALS is an +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*")) + (prompt (or prompt "Select: ")) + current) + (unwind-protect + (catch 'exit + (while t + (erase-buffer) + (insert title "\n\n") + (let ((des-keys nil) + (allowed-keys '("\C-g")) + (tab-alternatives '("\s" "\t" "\r")) + (cursor-type nil)) + ;; Populate allowed keys and descriptions keys + ;; available with CURRENT selector. + (let ((re (format "\\`%s\\(.\\)\\'" + (if current (regexp-quote current) ""))) + (prefix (if current (concat current " ") ""))) + (dolist (entry table) + (pcase entry + ;; Description. + (`(,(and key (pred (string-match re))) ,desc) + (let ((k (match-string 1 key))) + (push k des-keys) + ;; Keys ending in tab, space or RET are equivalent. + (if (member k tab-alternatives) + (push "\t" allowed-keys) + (push k allowed-keys)) + (insert prefix "[" k "]" "..." " " desc "..." "\n"))) + ;; Usable entry. + (`(,(and key (pred (string-match re))) ,desc . ,_) + (let ((k (match-string 1 key))) + (insert prefix "[" k "]" " " desc "\n") + (push k allowed-keys))) + (_ nil)))) + ;; Insert special entries, if any. + (when specials + (insert "----------------------------------------------------\ +---------------------------\n") + (pcase-dolist (`(,key ,description) specials) + (insert (format "[%s] %s\n" key description)) + (push key allowed-keys))) + ;; Display UI and let user select an entry or + ;; a sub-level prefix. + (goto-char (point-min)) + (unless (pos-visible-in-window-p (point-max)) + (org-fit-window-to-buffer)) + (let ((pressed (org--mks-read-key allowed-keys prompt))) + (setq current (concat current pressed)) + (cond + ((equal pressed "\C-g") (user-error "Abort")) + ;; Selection is a prefix: open a new menu. + ((member pressed des-keys)) + ;; Selection matches an association: return it. + ((let ((entry (assoc current table))) + (and entry (throw 'exit entry)))) + ;; Selection matches a special entry: return the + ;; selection prefix. + ((assoc current specials) (throw 'exit current)) + (t (error "No entry available"))))))) + (when buffer (kill-buffer buffer)))))) + + +;;; List manipulation + +(defsubst org-get-alist-option (option key) + (cond ((eq key t) t) + ((eq option t) t) + ((assoc key option) (cdr (assoc key option))) + (t (let ((r (cdr (assq 'default option)))) + (if (listp r) (delq nil r) r))))) + +(defsubst org-last (list) + "Return the last element of LIST." + (car (last list))) + +(defsubst org-uniquify (list) + "Non-destructively remove duplicate elements from LIST." + (let ((res (copy-sequence list))) (delete-dups res))) + +(defun org-uniquify-alist (alist) + "Merge elements of ALIST with the same key. + +For example, in this alist: + +\(org-uniquify-alist \\='((a 1) (b 2) (a 3))) + => \\='((a 1 3) (b 2)) + +merge (a 1) and (a 3) into (a 1 3). + +The function returns the new ALIST." + (let (rtn) + (dolist (e alist rtn) + (let (n) + (if (not (assoc (car e) rtn)) + (push e rtn) + (setq n (cons (car e) (append (cdr (assoc (car e) rtn)) (cdr e)))) + (setq rtn (assq-delete-all (car e) rtn)) + (push n rtn)))))) + +(defun org-delete-all (elts list) + "Remove all elements in ELTS from LIST. +Comparison is done with `equal'. It is a destructive operation +that may remove elements by altering the list structure." + (while elts + (setq list (delete (pop elts) list))) + list) + +(defun org-plist-delete (plist property) + "Delete PROPERTY from PLIST. +This is in contrast to merely setting it to 0." + (let (p) + (while plist + (if (not (eq property (car plist))) + (setq p (plist-put p (car plist) (nth 1 plist)))) + (setq plist (cddr plist))) + p)) + +(defun org-combine-plists (&rest plists) + "Create a single property list from all plists in PLISTS. +The process starts by copying the first list, and then setting properties +from the other lists. Settings in the last list are the most significant +ones and overrule settings in the other lists." + (let ((rtn (copy-sequence (pop plists))) + p v ls) + (while plists + (setq ls (pop plists)) + (while ls + (setq p (pop ls) v (pop ls)) + (setq rtn (plist-put rtn p v)))) + rtn)) + + + +;;; Local variables + (defconst org-unique-local-variables '(org-element--cache org-element--cache-objects @@ -425,6 +585,604 @@ Optional argument REGEXP selects variables to clone." (or (null regexp) (string-match-p regexp (symbol-name name)))) (ignore-errors (set (make-local-variable name) value))))))) + +;;; Miscellaneous + +(defsubst org-call-with-arg (command arg) + "Call COMMAND interactively, but pretend prefix arg was ARG." + (let ((current-prefix-arg arg)) (call-interactively command))) + +(defsubst org-check-external-command (cmd &optional use no-error) + "Check if external program CMD for USE exists, error if not. +When the program does exist, return its path. +When it does not exist and NO-ERROR is set, return nil. +Otherwise, throw an error. The optional argument USE can describe what this +program is needed for, so that the error message can be more informative." + (or (executable-find cmd) + (if no-error + nil + (error "Can't find `%s'%s" cmd + (if use (format " (%s)" use) ""))))) + +(defun org-display-warning (message) + "Display the given MESSAGE as a warning." + (display-warning 'org message :warning)) + +(defun org-unlogged-message (&rest args) + "Display a message, but avoid logging it in the *Messages* buffer." + (let ((message-log-max nil)) + (apply #'message args))) + +(defun org-let (list &rest body) + (eval (cons 'let (cons list body)))) +(put 'org-let 'lisp-indent-function 1) + +(defun org-let2 (list1 list2 &rest body) + (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body))))))) +(put 'org-let2 'lisp-indent-function 2) + +(defun org-eval (form) + "Eval FORM and return result." + (condition-case error + (eval form) + (error (format "%%![Error: %s]" error)))) + +(defvar org-outline-regexp) ; 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 () + "Return outline-regexp with limited number of levels. +The number of levels is controlled by `org-inlinetask-min-level'." + (cond ((not (derived-mode-p 'org-mode)) + outline-regexp) + ((not (featurep 'org-inlinetask)) + 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))))) + + + +;;; Motion + +(defsubst org-goto-line (N) + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- N)))) + +(defsubst org-current-line (&optional pos) + (save-excursion + (and pos (goto-char pos)) + ;; works also in narrowed buffer, because we start at 1, not point-min + (+ (if (bolp) 1 0) (count-lines 1 (point))))) + + + +;;; Overlays + +(defun org-overlay-display (ovl text &optional face evap) + "Make overlay OVL display TEXT with face FACE." + (overlay-put ovl 'display text) + (when face (overlay-put ovl 'face face)) + (when evap (overlay-put ovl 'evaporate t))) + +(defun org-overlay-before-string (ovl text &optional face evap) + "Make overlay OVL display TEXT with face FACE." + (when face (org-add-props text nil 'face face)) + (overlay-put ovl 'before-string text) + (when evap (overlay-put ovl 'evaporate t))) + +(defun org-find-overlays (prop &optional pos delete) + "Find all overlays specifying PROP at POS or point. +If DELETE is non-nil, delete all those overlays." + (let (found) + (dolist (ov (overlays-at (or pos (point))) found) + (cond ((not (overlay-get ov prop))) + (delete (delete-overlay ov)) + (t (push ov found)))))) + +(defun org-flag-region (from to flag spec) + "Hide or show lines from FROM to TO, according to FLAG. +SPEC is the invisibility spec, as a symbol." + (remove-overlays from to 'invisible spec) + ;; Use `front-advance' since text right before to the beginning of + ;; the overlay belongs to the visible line than to the contents. + (when flag + (let ((o (make-overlay from to nil 'front-advance))) + (overlay-put o 'evaporate t) + (overlay-put o 'invisible spec) + (overlay-put o 'isearch-open-invisible #'delete-overlay)))) + + + +;;; Regexp matching + +(defsubst org-pos-in-match-range (pos n) + (and (match-beginning n) + (<= (match-beginning n) pos) + (>= (match-end n) pos))) + +(defun 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) + (looking-at regexp))) + +(defun org-match-any-p (re list) + "Non-nil if regexp RE matches an element in LIST." + (cl-some (lambda (x) (string-match-p re x)) list)) + +(defun org-in-regexp (regexp &optional nlines visually) + "Check if point is inside a match of REGEXP. + +Normally only the current line is checked, but you can include +NLINES extra lines around point into the search. If VISUALLY is +set, require that the cursor is not after the match but really +on, so that the block visually is on the match. + +Return nil or a cons cell (BEG . END) where BEG and END are, +respectively, the positions at the beginning and the end of the +match." + (catch :exit + (let ((pos (point)) + (eol (line-end-position (if nlines (1+ nlines) 1)))) + (save-excursion + (beginning-of-line (- 1 (or nlines 0))) + (while (and (re-search-forward regexp eol t) + (<= (match-beginning 0) pos)) + (let ((end (match-end 0))) + (when (or (> end pos) (and (= end pos) (not visually))) + (throw :exit (cons (match-beginning 0) (match-end 0)))))))))) + +(defun org-point-in-group (point group &optional context) + "Check if POINT is in match-group GROUP. +If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the +match. If the match group does not exist or point is not inside it, +return nil." + (and (match-beginning group) + (>= point (match-beginning group)) + (<= point (match-end group)) + (if context + (list context (match-beginning group) (match-end group)) + t))) + + + +;;; String manipulation + +(defun org-string< (a b) + (org-string-collate-lessp a b)) + +(defun org-string<= (a b) + (or (string= a b) (org-string-collate-lessp a b))) + +(defun org-string>= (a b) + (not (org-string-collate-lessp a b))) + +(defun org-string> (a b) + (and (not (string= a b)) + (not (org-string-collate-lessp a b)))) + +(defun org-string<> (a b) + (not (string= a b))) + +(defsubst org-trim (s &optional keep-lead) + "Remove whitespace at the beginning and the end of string S. +When optional argument KEEP-LEAD is non-nil, removing blank lines +at the beginning of the string does not affect leading indentation." + (replace-regexp-in-string + (if keep-lead "\\`\\([ \t]*\n\\)+" "\\`[ \t\n\r]+") "" + (replace-regexp-in-string "[ \t\n\r]+\\'" "" s))) + +(defun org-string-nw-p (s) + "Return S if S is a string containing a non-blank character. +Otherwise, return nil." + (and (stringp s) + (string-match-p "[^ \r\t\n]" s) + s)) + +(defun org-reverse-string (string) + "Return the reverse of STRING." + (apply #'string (nreverse (string-to-list string)))) + +(defun org-split-string (string &optional separators) + "Splits STRING into substrings at SEPARATORS. + +SEPARATORS is a regular expression. When nil, it defaults to +\"[ \f\t\n\r\v]+\". + +Unlike `split-string', matching SEPARATORS at the beginning and +end of string are ignored." + (let ((separators (or separators "[ \f\t\n\r\v]+"))) + (if (not (string-match separators string)) (list string) + (let ((i (match-end 0)) + (results + (and (/= 0 (match-beginning 0)) ;skip leading separator + (list (substring string 0 (match-beginning 0)))))) + (while (string-match separators string i) + (push (substring string i (match-beginning 0)) + results) + (setq i (match-end 0))) + (nreverse (if (= i (length string)) + results ;skip trailing separator + (cons (substring string i) results))))))) + +(defun org--string-from-props (s property beg end) + "Return the visible part of string S. +Visible part is determined according to text PROPERTY, which is +either `invisible' or `display'. BEG and END are 0-indices +delimiting S." + (let ((width 0) + (cursor beg)) + (while (setq beg (text-property-not-all beg end property nil s)) + (let* ((next (next-single-property-change beg property s end)) + (props (text-properties-at beg s)) + (spec (plist-get props property)) + (value + (pcase property + (`invisible + ;; If `invisible' property in PROPS means text is to + ;; be invisible, return 0. Otherwise return nil so + ;; as to resume search. + (and (or (eq t buffer-invisibility-spec) + (assoc-string spec buffer-invisibility-spec)) + 0)) + (`display + (pcase spec + (`nil nil) + (`(space . ,props) + (let ((width (plist-get props :width))) + (and (wholenump width) width))) + (`(image . ,_) + (ceiling (car (image-size spec)))) + ((pred stringp) + ;; Displayed string could contain invisible parts, + ;; but no nested display. + (org--string-from-props spec 'invisible 0 (length spec))) + (_ + ;; Un-handled `display' value. Ignore it. + ;; Consider the original string instead. + nil))) + (_ (error "Unknown property: %S" property))))) + (when value + (cl-incf width + ;; When looking for `display' parts, we still need + ;; to look for `invisible' property elsewhere. + (+ (cond ((eq property 'display) + (org--string-from-props s 'invisible cursor beg)) + ((= cursor beg) 0) + (t (string-width (substring s cursor beg)))) + value)) + (setq cursor next)) + (setq beg next))) + (+ width + ;; Look for `invisible' property in the last part of the + ;; string. See above. + (cond ((eq property 'display) + (org--string-from-props s 'invisible cursor end)) + ((= cursor end) 0) + (t (string-width (substring s cursor end))))))) + +(defun org-string-width (string) + "Return width of STRING when displayed in the current buffer. +Unlike `string-width', this function takes into consideration +`invisible' and `display' text properties. It supports the +latter in a limited way, mostly for combinations used in Org. +Results may be off sometimes if it cannot handle a given +`display' value." + (org--string-from-props string 'display 0 (length string))) + +(defun org-not-nil (v) + "If V not nil, and also not the string \"nil\", then return V. +Otherwise return nil." + (and v (not (equal v "nil")) v)) + +(defun org-unbracket-string (pre post string) + "Remove PRE/POST from the beginning/end of STRING. +Both PRE and POST must be pre-/suffixes of STRING, or neither is +removed. Return the new string. If STRING is nil, return nil." + (declare (indent 2)) + (and string + (if (and (string-prefix-p pre string) + (string-suffix-p post string)) + (substring string (length pre) (- (length post))) + string))) + +(defun org-strip-quotes (string) + "Strip double quotes from around STRING, if applicable. +If STRING is nil, return nil." + (org-unbracket-string "\"" "\"" string)) + +(defsubst org-current-line-string (&optional to-here) + "Return current line, as a string. +If optional argument TO-HERE is non-nil, return string from +beginning of line up to point." + (buffer-substring (line-beginning-position) + (if to-here (point) (line-end-position)))) + +(defun org-shorten-string (s maxlength) + "Shorten string S so that it is no longer than MAXLENGTH characters. +If the string is shorter or has length MAXLENGTH, just return the +original string. If it is longer, the functions finds a space in the +string, breaks this string off at that locations and adds three dots +as ellipsis. Including the ellipsis, the string will not be longer +than MAXLENGTH. If finding a good breaking point in the string does +not work, the string is just chopped off in the middle of a word +if necessary." + (if (<= (length s) maxlength) + s + (let* ((n (max (- maxlength 4) 1)) + (re (concat "\\`\\(.\\{1," (int-to-string n) "\\}[^ ]\\)\\([ ]\\|\\'\\)"))) + (if (string-match re s) + (concat (match-string 1 s) "...") + (concat (substring s 0 (max (- maxlength 3) 0)) "..."))))) + +(defun org-remove-tabs (s &optional width) + "Replace tabulators in S with spaces. +Assumes that s is a single line, starting in column 0." + (setq width (or width tab-width)) + (while (string-match "\t" s) + (setq s (replace-match + (make-string + (- (* width (/ (+ (match-beginning 0) width) width)) + (match-beginning 0)) ?\ ) + t t s))) + 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 +that costs. If there is a word longer than WIDTH, the text is actually +wrapped to the length of that word. +IF WIDTH is nil and LINES is non-nil, the string is forced into at most that +many lines, whatever width that takes. +The return value is a list of lines, without newlines at the end." + (let* ((words (split-string string)) + (maxword (apply 'max (mapcar 'org-string-width words))) + w ll) + (cond (width + (org--do-wrap words (max maxword width))) + (lines + (setq w maxword) + (setq ll (org--do-wrap words maxword)) + (if (<= (length ll) lines) + ll + (setq ll words) + (while (> (length ll) lines) + (setq w (1+ w)) + (setq ll (org--do-wrap words w))) + ll)) + (t (error "Cannot wrap this"))))) + +(defun org--do-wrap (words width) + "Create lines of maximum width WIDTH (in characters) from word list WORDS." + (let (lines line) + (while words + (setq line (pop words)) + (while (and words (< (+ (length line) (length (car words))) width)) + (setq line (concat line " " (pop words)))) + (setq lines (push line lines))) + (nreverse lines))) + +(defun org-remove-indentation (code &optional n) + "Remove maximum common indentation in string CODE and return it. +N may optionally be the number of columns to remove. Return CODE +as-is if removal failed." + (with-temp-buffer + (insert code) + (if (org-do-remove-indentation n) (buffer-string) code))) + +(defun org-fill-template (template alist) + "Find each %key of ALIST in TEMPLATE and replace it." + (let ((case-fold-search nil)) + (dolist (entry (sort (copy-sequence alist) + (lambda (a b) (< (length (car a)) (length (car b)))))) + (setq template + (replace-regexp-in-string + (concat "%" (regexp-quote (car entry))) + (or (cdr entry) "") template t t))) + template)) + +(defun org-replace-escapes (string table) + "Replace %-escapes in STRING with values in TABLE. +TABLE is an association list with keys like \"%a\" and string values. +The sequences in STRING may contain normal field width and padding information, +for example \"%-5s\". Replacements happen in the sequence given by TABLE, +so values can contain further %-escapes if they are define later in TABLE." + (let ((tbl (copy-alist table)) + (case-fold-search nil) + (pchg 0) + re rpl) + (dolist (e tbl) + (setq re (concat "%-?[0-9.]*" (substring (car e) 1))) + (when (and (cdr e) (string-match re (cdr e))) + (let ((sref (substring (cdr e) (match-beginning 0) (match-end 0))) + (safe "SREF")) + (add-text-properties 0 3 (list 'sref sref) safe) + (setcdr e (replace-match safe t t (cdr e))))) + (while (string-match re string) + (setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s") + (cdr e))) + (setq string (replace-match rpl t t string)))) + (while (setq pchg (next-property-change pchg string)) + (let ((sref (get-text-property pchg 'sref string))) + (when (and sref (string-match "SREF" string pchg)) + (setq string (replace-match sref t t string))))) + string)) + + +;;; Text properties + +(defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t + rear-nonsticky t mouse-map t fontified t + org-emphasis t) + "Properties to remove when a string without properties is wanted.") + +(defsubst org-no-properties (s &optional restricted) + "Remove all text properties from string S. +When RESTRICTED is non-nil, only remove the properties listed +in `org-rm-props'." + (if restricted (remove-text-properties 0 (length s) org-rm-props s) + (set-text-properties 0 (length s) nil s)) + s) +(defun org-add-props (string plist &rest props) + "Add text properties to entire string, from beginning to end. +PLIST may be a list of properties, PROPS are individual properties and values +that will be added to PLIST. Returns the string that was modified." + (declare (indent 2)) + (add-text-properties + 0 (length string) (if props (append plist props) plist) string) + string) + +(defun org-make-parameter-alist (flat) + "Return alist based on FLAT. +FLAT is a list with alternating symbol names and values. The +returned alist is a list of lists with the symbol name in car and +the value in cdr." + (when flat + (cons (list (car flat) (cadr flat)) + (org-make-parameter-alist (cddr flat))))) + +(defsubst org-get-at-bol (property) + "Get text property PROPERTY at the beginning of line." + (get-text-property (point-at-bol) property)) + +(defun org-get-at-eol (property n) + "Get text property PROPERTY at the end of line less N characters." + (get-text-property (- (point-at-eol) n) property)) + +(defun org-find-text-property-in-string (prop s) + "Return the first non-nil value of property PROP in string S." + (or (get-text-property 0 prop s) + (get-text-property (or (next-single-property-change 0 prop s) 0) + prop s))) + +(defun org-invisible-p (&optional pos) + "Non-nil if the character after POS is invisible. +If POS is nil, use `point' instead." + (get-char-property (or pos (point)) 'invisible)) + +(defun org-truely-invisible-p () + "Check if point is at a character currently not visible. +This version does not only check the character property, but also +`visible-mode'." + (unless (bound-and-true-p visible-mode) + (org-invisible-p))) + +(defun org-invisible-p2 () + "Check if point is at a character currently not visible. +If the point is at EOL (and not at the beginning of a buffer too), +move it back by one char before doing this check." + (save-excursion + (when (and (eolp) (not (bobp))) + (backward-char 1)) + (org-invisible-p))) + + +;;; Time + +(defun org-2ft (s) + "Convert S to a floating point time. +If S is already a number, just return it. If it is a string, +parse it as a time string and apply `float-time' to it. If S is +nil, just return 0." + (cond + ((numberp s) s) + ((stringp s) + (condition-case nil + (float-time (apply #'encode-time (org-parse-time-string s))) + (error 0))) + (t 0))) + +(defun org-time= (a b) + (let ((a (org-2ft a)) + (b (org-2ft b))) + (and (> a 0) (> b 0) (= a b)))) + +(defun org-time< (a b) + (let ((a (org-2ft a)) + (b (org-2ft b))) + (and (> a 0) (> b 0) (< a b)))) + +(defun org-time<= (a b) + (let ((a (org-2ft a)) + (b (org-2ft b))) + (and (> a 0) (> b 0) (<= a b)))) + +(defun org-time> (a b) + (let ((a (org-2ft a)) + (b (org-2ft b))) + (and (> a 0) (> b 0) (> a b)))) + +(defun org-time>= (a b) + (let ((a (org-2ft a)) + (b (org-2ft b))) + (and (> a 0) (> b 0) (>= a b)))) + +(defun org-time<> (a b) + (let ((a (org-2ft a)) + (b (org-2ft b))) + (and (> a 0) (> b 0) (\= a b)))) + +(defun org-parse-time-string (s &optional nodefault) + "Parse Org time string S. + +If time is not given, defaults to 0:00. However, with optional +NODEFAULT, hour and minute fields are nil if not given. + +Throw an error if S does not contain a valid Org time string. +Note that the first match for YYYY-MM-DD will be used (e.g., +\"-52000-02-03\" will be taken as \"2000-02-03\"). + +This should be a lot faster than the `parse-time-string'." + (unless (string-match org-ts-regexp0 s) + (error "Not an Org time string: %s" s)) + (list 0 + (cond ((match-beginning 8) (string-to-number (match-string 8 s))) + (nodefault nil) + (t 0)) + (cond ((match-beginning 7) (string-to-number (match-string 7 s))) + (nodefault nil) + (t 0)) + (string-to-number (match-string 4 s)) + (string-to-number (match-string 3 s)) + (string-to-number (match-string 2 s)) + nil nil nil)) + +(defun org-matcher-time (s) + "Interpret a time comparison value S as a floating point time. + +S can be an Org time stamp, a modifier, e.g., \"<+2d>\", or the +following special strings: \"<now>\", \"<today>\", +\"<tomorrow>\", and \"<yesterday>\". + +Return 0. if S is not recognized as a valid value." + (let ((today (float-time (apply #'encode-time + (append '(0 0 0) (nthcdr 3 (decode-time))))))) + (save-match-data + (cond + ((string= s "<now>") (float-time)) + ((string= s "<today>") today) + ((string= s "<tomorrow>") (+ 86400.0 today)) + ((string= s "<yesterday>") (- today 86400.0)) + ((string-match "\\`<\\([-+][0-9]+\\)\\([hdwmy]\\)>\\'" s) + (+ today + (* (string-to-number (match-string 1 s)) + (cdr (assoc (match-string 2 s) + '(("d" . 86400.0) ("w" . 604800.0) + ("m" . 2678400.0) ("y" . 31557600.0))))))) + ((string-match org-ts-regexp0 s) (org-2ft s)) + (t 0.))))) + + (provide 'org-macs) diff --git a/lisp/org/org-mobile.el b/lisp/org/org-mobile.el index dba6ca22f9b..26a3f577dac 100644 --- a/lisp/org/org-mobile.el +++ b/lisp/org/org-mobile.el @@ -24,18 +24,17 @@ ;; ;;; Commentary: ;; -;; This file contains the code to interact with Richard Moreland's -;; iPhone application MobileOrg, as well as with the Android version -;; by Matthew Jones. This code is documented in Appendix B of the Org -;; manual. The code is not specific for the iPhone and Android - any -;; external viewer/flagging/editing application that uses the same -;; conventions could be used. +;; This file contains the code to interact with a mobile application, +;; such as Richard Moreland's iPhone application MobileOrg, or the +;; Android version by Matthew Jones. This code is documented in +;; Appendix B of the Org manual. The code is not specific for the +;; iPhone and Android - any external viewer/flagging/editing +;; application that uses the same conventions could be used. +(require 'cl-lib) (require 'org) (require 'org-agenda) -(require 'cl-lib) - -(defvar org-agenda-keep-restricted-file-list) +(require 'ol) ;;; Code: @@ -45,15 +44,17 @@ :group 'org) (defcustom org-mobile-files '(org-agenda-files) - "Files to be staged for MobileOrg. + "Files to be staged for the mobile application. + This is basically a list of files and directories. Files will be staged -directly. Directories will be search for files with the extension `.org'. +directly. Directories will be search for files with the extension \".org\". In addition to this, the list may also contain the following symbols: -org-agenda-files +`org-agenda-files' This means include the complete, unrestricted list of files given in the variable `org-agenda-files'. -org-agenda-text-search-extra-files + +`org-agenda-text-search-extra-files' Include the files given in the variable `org-agenda-text-search-extra-files'." :group 'org-mobile @@ -84,12 +85,14 @@ org-agenda-text-search-extra-files (defcustom org-mobile-use-encryption nil "Non-nil means keep only encrypted files on the WebDAV server. + Encryption uses AES-256, with a password given in -`org-mobile-encryption-password'. -When nil, plain files are kept on the server. -Turning on encryption requires setting the same password in the MobileOrg -application. Before turning this on, check of MobileOrg does already -support it - at the time of this writing it did not yet." +`org-mobile-encryption-password'. When nil, plain files are kept +on the server. + +Turning on encryption requires setting the same password in the +mobile application. Before turning this on, check if the mobile +application does support it." :group 'org-mobile :version "24.1" :type 'boolean) @@ -104,9 +107,10 @@ You might want to put this file into a directory where only you have access." (defcustom org-mobile-encryption-password "" "Password for encrypting files uploaded to the server. + This is a single password which is used for AES-256 encryption. The same -password must also be set in the MobileOrg application. All Org files, -including mobileorg.org will be encrypted using this password. +password must also be set in the mobile application. All Org files, +including \"mobileorg.org\" will be encrypted using this password. SECURITY CONSIDERATIONS: @@ -129,12 +133,12 @@ session." (or (org-string-nw-p org-mobile-encryption-password) (org-string-nw-p org-mobile-encryption-password-session) (setq org-mobile-encryption-password-session - (read-passwd "Password for MobileOrg: " t)))) + (read-passwd "Password for mobile application: " t)))) (defcustom org-mobile-inbox-for-pull "~/org/from-mobile.org" "The file where captured notes and flags will be appended to. During the execution of `org-mobile-pull', the file -`org-mobile-capture-file' will be emptied it's contents have +`org-mobile-capture-file' is emptied as soon as its contents have been appended to the file given here. This file should be in `org-directory', and not in the staging area or on the web server." :group 'org-mobile @@ -142,23 +146,25 @@ been appended to the file given here. This file should be in (defconst org-mobile-capture-file "mobileorg.org" "The capture file where the mobile stores captured notes and flags. -This should not be changed, because MobileOrg assumes this name.") +This must not be changed, because the mobile application assumes this name.") (defcustom org-mobile-index-file "index.org" - "The index file with links to all Org files that should be loaded by MobileOrg. -Relative to `org-mobile-directory'. The Address field in the MobileOrg setup -should point to this file." + "Index file with links to all Org files. +It should be loaded by the mobile application. The file name is +relative to `org-mobile-directory'. The \"Address\" field in the +mobile application setup should point to this file." :group 'org-mobile :type 'file) (defcustom org-mobile-agendas 'all - "The agendas that should be pushed to MobileOrg. + "The agendas that should be pushed to the mobile application. + Allowed values: -default the weekly agenda and the global TODO list -custom all custom agendas defined by the user -all the custom agendas and the default ones -list a list of selection key(s) as string." +`default' the weekly agenda and the global TODO list +`custom' all custom agendas defined by the user +`all' the custom agendas and the default ones +`list' a list of selection key(s) as string." :group 'org-mobile :version "24.1" :type '(choice @@ -229,7 +235,9 @@ using `rsync' or `scp'.") (defconst org-mobile-action-alist '(("edit" . org-mobile-edit)) "Alist with flags and actions for mobile sync. -When flagging an entry, MobileOrg will create entries that look like + +When flagging an entry, the mobile application creates entries +that look like * F(action:data) [[id:entry-id][entry title]] @@ -311,6 +319,11 @@ create all custom agenda views, for upload to the mobile phone." (let ((org-agenda-buffer-name "*SUMO*") (org-agenda-tag-filter org-agenda-tag-filter) (org-agenda-redo-command org-agenda-redo-command)) + ;; Offer to save agenda-related buffers before pushing, preventing + ;; "Non-existent agenda file" prompt for lock files (see #19448). + (let ((agenda-buffers (org-buffer-list 'agenda))) + (save-some-buffers nil + (lambda () (memq (current-buffer) agenda-buffers)))) (save-excursion (save-restriction (save-window-excursion @@ -656,8 +669,7 @@ The table of checksums is written to the file mobile-checksums." (org-mobile-escape-olp (nth 4 (org-heading-components)))))) (defun org-mobile-escape-olp (s) - (let ((table '(?: ?/))) - (org-link-escape s table))) + (org-link-encode s '(?: ?/))) (defun org-mobile-create-sumo-agenda () "Create a file that contains all custom agenda views." @@ -869,7 +881,7 @@ If BEG and END are given, only do this in that region." (funcall cmd data old new) (unless (member data '("delete" "archive" "archive-sibling" "addheading")) - (when (member "FLAGGED" (org-get-tags)) + (when (member "FLAGGED" (org-get-tags nil t)) (add-to-list 'org-mobile-last-flagged-files (buffer-file-name))))) (error (setq org-mobile-error msg))) @@ -951,7 +963,7 @@ is currently a noop.") (if (not (string-match "\\`olp:\\(.*?\\)$" link)) nil (let ((file (match-string 1 link))) - (setq file (org-link-unescape file)) + (setq file (org-link-decode file)) (setq file (expand-file-name file org-directory)) (save-excursion (find-file file) @@ -961,9 +973,9 @@ is currently a noop.") (point-marker)))) (let ((file (match-string 1 link)) (path (match-string 2 link))) - (setq file (org-link-unescape file)) + (setq file (org-link-decode file)) (setq file (expand-file-name file org-directory)) - (setq path (mapcar 'org-link-unescape + (setq path (mapcar #'org-link-decode (org-split-string path "/"))) (org-find-olp (cons file path)))))) @@ -994,7 +1006,7 @@ be returned that indicates what went wrong." old current)))) ((eq what 'tags) - (setq current (org-get-tags) + (setq current (org-get-tags nil t) new1 (and new (org-split-string new ":+")) old1 (and old (org-split-string old ":+"))) (cond @@ -1002,7 +1014,7 @@ be returned that indicates what went wrong." ((or (org-mobile-tags-same-p current old1) (eq org-mobile-force-mobile-change t) (memq 'tags org-mobile-force-mobile-change)) - (org-set-tags-to new1) t) + (org-set-tags new1) t) (t (error "Tags before change were expected as \"%s\", but are \"%s\"" (or old "") (or current ""))))) @@ -1031,8 +1043,10 @@ be returned that indicates what went wrong." (goto-char (match-beginning 4)) (insert new) (delete-region (point) (+ (point) (length current))) - (org-set-tags nil 'align)) - (t (error "Heading changed in MobileOrg and on the computer"))))))) + (org-align-tags)) + (t + (error + "Heading changed in the mobile device and on the computer"))))))) ((eq what 'addheading) (if (org-at-heading-p) ; if false we are in top-level of file @@ -1085,7 +1099,8 @@ be returned that indicates what went wrong." (outline-next-heading) (point)))) t) - (t (error "Body was changed in MobileOrg and on the computer"))))))) + (t (error + "Body was changed in the mobile device and on the computer"))))))) (defun org-mobile-tags-same-p (list1 list2) "Are the two tag lists the same?" diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el index a3dcb77554c..13d88dad7dc 100644 --- a/lisp/org/org-mouse.el +++ b/lisp/org/org-mouse.el @@ -422,7 +422,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:" (defun org-mouse-tag-menu () ;todo "Create the tags menu." (append - (let ((tags (org-get-tags))) + (let ((tags (org-get-tags nil t))) (org-mouse-keyword-menu (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp) `(lambda (tag) @@ -434,22 +434,12 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:" `(lambda (tag) (member tag (quote ,tags))) )) '("--" - ["Align Tags Here" (org-set-tags nil t) t] - ["Align Tags in Buffer" (org-set-tags t t) t] - ["Set Tags ..." (org-set-tags) t]))) + ["Align Tags Here" (org-align-tags) t] + ["Align Tags in Buffer" (org-align-tags t) t] + ["Set Tags ..." (org-set-tags-command) t]))) (defun org-mouse-set-tags (tags) - (save-excursion - ;; remove existing tags first - (beginning-of-line) - (when (org-mouse-re-search-line ":\\(\\([A-Za-z_]+:\\)+\\)") - (replace-match "")) - - ;; set new tags if any - (when tags - (end-of-line) - (insert " :" (mapconcat 'identity tags ":") ":") - (org-set-tags nil t)))) + (org-set-tags tags)) (defun org-mouse-insert-checkbox () (interactive) @@ -498,7 +488,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:" `("Main Menu" ["Show Overview" org-mouse-show-overview t] ["Show Headlines" org-mouse-show-headlines t] - ["Show All" outline-show-all t] + ["Show All" org-show-all t] ["Remove Highlights" org-remove-occur-highlights :visible org-occur-highlights] "--" diff --git a/lisp/org/org-num.el b/lisp/org/org-num.el new file mode 100644 index 00000000000..56048191b8f --- /dev/null +++ b/lisp/org/org-num.el @@ -0,0 +1,469 @@ +;;; org-num.el --- Dynamic Headlines Numbering -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr> +;; Keywords: outlines, hypermedia, calendar, wp + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library provides dynamic numbering for Org headlines. Use +;; +;; <M-x org-num-mode> +;; +;; to toggle it. +;; +;; You can select what is numbered according to level, tags, COMMENT +;; keyword, or UNNUMBERED property. You can also skip footnotes +;; sections. See `org-num-max-level', `org-num-skip-tags', +;; `org-num-skip-commented', `org-num-skip-unnumbered', and +;; `org-num-skip-footnotes' for details. +;; +;; You can also control how the numbering is displayed by setting +;;`org-num-face' and `org-num-format-function'. +;; +;; Internally, the library handles an ordered list, per buffer +;; position, of overlays in `org-num--overlays'. These overlays are +;; marked with the `org-num' property set to a non-nil value. +;; +;; Overlays store the level of the headline in the `level' property, +;; and the face used for the numbering in `numbering-face'. +;; +;; The `skip' property is set to t when the corresponding headline has +;; some characteristic -- e.g., a node property, or a tag -- that +;; prevents it from being numbered. +;; +;; An overlay with `org-num' property set to `invalid' is called an +;; invalid overlay. Modified overlays automatically become invalid +;; and set `org-num--invalid-flag' to a non-nil value. After +;; a change, `org-num--invalid-flag' indicates numbering needs to be +;; updated and invalid overlays indicate where the buffer needs to be +;; parsed. So does `org-num--missing-overlay' variable. See +;; `org-num--verify' function for details. +;; +;; Numbering display is done through the `after-string' property. + + +;;; Code: + +(require 'cl-lib) +(require 'org-macs) + +(defvar org-comment-string) +(defvar org-complex-heading-regexp) +(defvar org-cycle-level-faces) +(defvar org-footnote-section) +(defvar org-level-faces) +(defvar org-n-level-faces) +(defvar org-odd-levels-only) + +(declare-function org-back-to-heading "org" (&optional invisible-ok)) +(declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) +(declare-function org-reduced-level "org" (l)) + + +;;; Customization + +(defcustom org-num-face nil + "Face to use for numbering. +When nil, use the same face as the headline. This value is +ignored if `org-num-format-function' specifies a face for its +output." + :group 'org-appearance + :package-version '(Org . "9.3") + :type '(choice (const :tag "Like the headline" nil) + (face :tag "Use face")) + :safe (lambda (val) (or (null val) (facep val)))) + +(defcustom org-num-format-function 'org-num-default-format + "Function used to display numbering. +It is called with one argument, a list of numbers, and should +return a string, or nil. When nil, no numbering is displayed. +Any `face' text property on the returned string overrides +`org-num-face'." + :group 'org-appearance + :package-version '(Org . "9.3") + :type 'function + :safe nil) + +(defcustom org-num-max-level nil + "Level below which headlines are not numbered. +When set to nil, all headlines are numbered." + :group 'org-appearance + :package-version '(Org . "9.3") + :type '(choice (const :tag "Number everything" nil) + (integer :tag "Stop numbering at level")) + :safe (lambda (val) (or (null val) (wholenump val)))) + +(defcustom org-num-skip-commented nil + "Non-nil means commented sub-trees are not numbered." + :group 'org-appearance + :package-version '(Org . "9.3") + :type 'boolean + :safe #'booleanp) + +(defcustom org-num-skip-footnotes nil + "Non-nil means footnotes sections are not numbered." + :group 'org-appearance + :package-version '(Org . "9.3") + :type 'boolean + :safe #'booleanp) + +(defcustom org-num-skip-tags nil + "List of tags preventing the numbering of sub-trees. + +For example, add \"ARCHIVE\" to this list to avoid numbering +archived sub-trees. + +Tag in this list prevent numbering the whole sub-tree, +irrespective to `org-use-tags-inheritance', or other means to +control tag inheritance." + :group 'org-appearance + :package-version '(Org . "9.3") + :type '(repeat (string :tag "Tag")) + :safe (lambda (val) (and (listp val) (cl-every #'stringp val)))) + +(defcustom org-num-skip-unnumbered nil + "Non-nil means numbering obeys to UNNUMBERED property." + :group 'org-appearance + :package-version '(Org . "9.3") + :type 'boolean + :safe #'booleanp) + + +;;; Internal Variables + +(defconst org-num--comment-re (format "\\`%s\\(?: \\|$\\)" org-comment-string) + "Regexp matching a COMMENT keyword at headline beginning.") + +(defvar-local org-num--overlays nil + "Ordered list of overlays used for numbering outlines.") + +(defvar-local org-num--skip-level nil + "Level below which headlines from current tree are not numbered. +When nil, all headlines are numbered. It is used to handle +inheritance of no-numbering attributes.") + +(defvar-local org-num--numbering nil + "Current headline numbering. +A numbering is a list of integers, in reverse order. So numbering +for headline \"1.2.3\" is (3 2 1).") + +(defvar-local org-num--missing-overlay nil + "Buffer position signaling a headline without an overlay.") + +(defvar-local org-num--invalid-flag nil + "Non-nil means an overlay became invalid since last update.") + + +;;; Internal Functions + +(defsubst org-num--headline-regexp () + "Return regexp matching a numbered headline." + (if (null org-num-max-level) (org-with-limited-levels org-outline-regexp-bol) + (format "^\\*\\{1,%d\\} " + (if org-odd-levels-only (1- (* 2 org-num-max-level)) + org-num-max-level)))) + +(defsubst org-num--overlay-p (o) + "Non-nil if overlay O is a numbering overlay." + (overlay-get o 'org-num)) + +(defsubst org-num--valid-overlay-p (o) + "Non-nil if overlay O is still active in the buffer." + (not (eq 'invalid (overlay-get o 'org-num)))) + +(defsubst org-num--invalidate-overlay (o) + "Mark overlay O as invalid. +Update `org-num--invalid-flag' accordingly." + (overlay-put o 'org-num 'invalid) + (setq org-num--invalid-flag t)) + +(defun org-num--clear () + "Remove all numbering overlays in current buffer." + (mapc #'delete-overlay org-num--overlays) + (setq org-num--overlays nil)) + +(defun org-num--make-overlay (numbering level skip) + "Return overlay for numbering headline at point. + +NUMBERING is the numbering to use, as a list of integers, or nil +if nothing should be displayed. LEVEL is the level of the +headline. SKIP is its skip value. + +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) + (skip-chars-forward "*") + (make-overlay (line-beginning-position) (1+ (point)))))) + (overlay-put o 'org-num t) + (overlay-put o 'skip skip) + (overlay-put o 'level level) + (overlay-put o 'numbering-face + (or org-num-face + ;; Compute face that would be used at the + ;; headline. We cannot extract it from the + ;; buffer: at the time the overlay is created, + ;; Font Lock has not proceeded yet. + (nth (if org-cycle-level-faces + (% (1- level) org-n-level-faces) + (1- (min level org-n-level-faces))) + org-level-faces))) + (overlay-put o 'modification-hooks after-edit-functions) + (overlay-put o 'insert-in-front-hooks after-edit-functions) + (org-num--refresh-display o numbering) + o)) + +(defun org-num--refresh-display (overlay numbering) + "Refresh OVERLAY's display. +NUMBERING specifies the new numbering, as a list of integers, or +nil if nothing should be displayed. Assume OVERLAY is valid." + (let ((display (and numbering + (funcall org-num-format-function (reverse numbering))))) + (when (and display (not (get-text-property 0 'face display))) + (org-add-props display `(face ,(overlay-get overlay 'numbering-face)))) + (overlay-put overlay 'after-string display))) + +(defun org-num--skip-value () + "Return skip value for headline at point. +Value is t when headline should not be numbered, and nil +otherwise." + (org-match-line org-complex-heading-regexp) + (let ((title (match-string 4)) + (tags (and org-num-skip-tags + (match-end 5) + (org-split-string (match-string 5) ":")))) + (or (and org-num-skip-footnotes + org-footnote-section + (equal title org-footnote-section)) + (and org-num-skip-commented + (let ((case-fold-search nil)) + (string-match org-num--comment-re title)) + t) + (and org-num-skip-tags + (cl-some (lambda (tag) (member tag org-num-skip-tags)) + tags) + t) + (and org-num-skip-unnumbered + (org-entry-get (point) "UNNUMBERED") + t)))) + +(defun org-num--current-numbering (level skip) + "Return numbering for current headline. +LEVEL is headline's level, and SKIP its skip value. Return nil +if headline should be skipped." + (cond + ;; Skipped by inheritance. + ((and org-num--skip-level (> level org-num--skip-level)) nil) + ;; Skipped by a non-nil skip value; set `org-num--skip-level' + ;; to skip the whole sub-tree later on. + (skip (setq org-num--skip-level level) nil) + (t + (setq org-num--skip-level nil) + ;; Compute next numbering, and update `org-num--numbering'. + (let ((last-level (length org-num--numbering))) + (setq org-num--numbering + (cond + ;; First headline : nil => (1), or (1 0)... + ((null org-num--numbering) (cons 1 (make-list (1- level) 0))) + ;; Sibling: (1 1) => (2 1). + ((= level last-level) + (cons (1+ (car org-num--numbering)) (cdr org-num--numbering))) + ;; Parent: (1 1 1) => (2 1), or (2). + ((< level last-level) + (let ((suffix (nthcdr (- last-level level) org-num--numbering))) + (cons (1+ (car suffix)) (cdr suffix)))) + ;; Child: (1 1) => (1 1 1), or (1 0 1 1)... + (t + (append (cons 1 (make-list (- level last-level 1) 0)) + org-num--numbering)))))))) + +(defun org-num--number-region (start end) + "Add numbering overlays between START and END positions. +When START or END are nil, use buffer boundaries. Narrowing, if +any, is ignored. Return the list of created overlays, newest +first." + (org-with-point-at (or start 1) + ;; Do not match headline starting at START. + (when start (end-of-line)) + (let ((regexp (org-num--headline-regexp)) + (new nil)) + (while (re-search-forward regexp end t) + (let* ((level (org-reduced-level + (- (match-end 0) (match-beginning 0) 1))) + (skip (org-num--skip-value)) + (numbering (org-num--current-numbering level skip))) + ;; Apply numbering to current headline. Store overlay for + ;; the return value. + (push (org-num--make-overlay numbering level skip) + new))) + new))) + +(defun org-num--update () + "Update buffer's numbering. +This function removes invalid overlays and refreshes numbering +for the valid ones in the numbering overlays list. It also adds +missing overlays to that list." + (setq org-num--skip-level nil) + (setq org-num--numbering nil) + (let ((new-overlays nil) + (overlay nil)) + (while (setq overlay (pop org-num--overlays)) + (cond + ;; Valid overlay. + ;; + ;; First handle possible missing overlays OVERLAY. If missing + ;; overlay marker is pointing before next overlay and after the + ;; last known overlay, make sure to parse the buffer between + ;; these two overlays. + ((org-num--valid-overlay-p overlay) + (let ((next (overlay-start overlay)) + (last (and new-overlays (overlay-start (car new-overlays))))) + (cond + ((null org-num--missing-overlay)) + ((> org-num--missing-overlay next)) + ((or (null last) (> org-num--missing-overlay last)) + (setq org-num--missing-overlay nil) + (setq new-overlays (nconc (org-num--number-region last next) + new-overlays))) + ;; If it is already after the last known overlay, reset it: + ;; some previous invalid overlay already triggered the + ;; necessary parsing. + (t + (setq org-num--missing-overlay nil)))) + ;; Update OVERLAY's numbering. + (let* ((level (overlay-get overlay 'level)) + (skip (overlay-get overlay 'skip)) + (numbering (org-num--current-numbering level skip))) + (org-num--refresh-display overlay numbering) + (push overlay new-overlays))) + ;; Invalid overlay. It indicates that the buffer needs to be + ;; parsed again between the two surrounding valid overlays or + ;; buffer boundaries. + (t + ;; Delete all consecutive invalid overlays: we re-create all + ;; overlays between last valid overlay and the next one. + (delete-overlay overlay) + (while (and org-num--overlays + (not (org-num--valid-overlay-p (car org-num--overlays)))) + (delete-overlay (pop org-num--overlays))) + ;; Create and register new overlays. + (let ((last (and new-overlays (overlay-start (car new-overlays)))) + (next (and org-num--overlays + (overlay-start (car org-num--overlays))))) + (setq new-overlays (nconc (org-num--number-region last next) + new-overlays)))))) + ;; If invalid position hasn't been handled yet, it must be located + ;; between last valid overlay and end of the buffer. Parse that + ;; area before returning. + (when org-num--missing-overlay + (let ((last (and new-overlays (overlay-start (car new-overlays))))) + (setq new-overlays (nconc (org-num--number-region last nil) + new-overlays)))) + ;; Numbering is now up-to-date. Reset invalid flag. Also return + ;; `org-num--overlays' in a sorted fashion. + (setq org-num--invalid-flag nil) + (setq org-num--overlays (nreverse new-overlays)))) + +(defun org-num--verify (beg end _) + "Check numbering integrity; update it if necessary. +This function is meant to be used in `after-change-functions'. +See this variable for the meaning of BEG and END." + (setq org-num--missing-overlay nil) + (save-match-data + (org-with-point-at beg + (let ((regexp (org-num--headline-regexp))) + ;; At this point, directly altered overlays between BEG and + ;; END are marked as invalid and will trigger a full update. + ;; However, there are still two cases to handle. + ;; + ;; First, some valid overlays may need to be invalidated, due + ;; to an indirect change. That happens when the skip value -- + ;; see `org-num--skip-value' -- of the heading BEG belongs to + ;; is altered, or when deleting the newline character right + ;; before the next headline. + (save-excursion + ;; Bail out if we're before first headline or within + ;; a headline too deep to be numbered. + (when (and (org-with-limited-levels + (ignore-errors (org-back-to-heading t))) + (looking-at regexp)) + (pcase (get-char-property-and-overlay (point) 'org-num) + (`(nil) + ;; At a headline, without a numbering overlay: change + ;; just created one. Mark it for parsing. + (setq org-num--missing-overlay (point))) + (`(t . ,o) + ;; Check if skip value changed. Invalidate overlay + ;; accordingly. + (unless (eq (org-num--skip-value) (overlay-get o 'skip)) + (org-num--invalidate-overlay o))) + (_ nil)))) + ;; Deleting the newline character before a numbering overlay + ;; doesn't invalidate it, even though it could land in the + ;; middle of a line. Be sure to catch this case. + (when (and (= beg end) (not (bolp))) + (pcase (get-char-property-and-overlay (point) 'org-num) + (`(t . ,o) (org-num--invalidate-overlay o)) + (_ nil))) + ;; Second, if nothing is marked as invalid, and therefore if + ;; no full update is due so far, changes may still have + ;; created new headlines, at BEG -- which is actually handled + ;; by the previous phase --, or, in case of a multi-line + ;; insertion, at END, or in-between. + (unless (or org-num--invalid-flag + org-num--missing-overlay + (<= end (line-end-position))) ;single line change + (forward-line) + (when (or (re-search-forward regexp end 'move) + ;; Check if change created a headline after END. + (progn (skip-chars-backward "*") (looking-at regexp))) + (setq org-num--missing-overlay (line-beginning-position)))))) + ;; Update numbering only if a headline was altered or created. + (when (or org-num--missing-overlay org-num--invalid-flag) + (org-num--update)))) + + +;;; Public Functions + +;;;###autoload +(defun org-num-default-format (numbering) + "Default numbering display function. +NUMBERING is a list of numbers." + (concat (mapconcat #'number-to-string numbering ".") " ")) + +;;;###autoload +(define-minor-mode org-num-mode + "Dynamic numbering of headlines in an Org buffer." + :lighter " o#" + (cond + (org-num-mode + (unless (derived-mode-p 'org-mode) + (user-error "Cannot activate headline numbering outside Org mode")) + (setq org-num--numbering nil) + (setq org-num--overlays (nreverse (org-num--number-region nil nil))) + (add-hook 'after-change-functions #'org-num--verify nil t) + (add-hook 'change-major-mode-hook #'org-num--clear nil t)) + (t + (org-num--clear) + (remove-hook 'after-change-functions #'org-num--verify t) + (remove-hook 'change-major-mode-hook #'org-num--clear t)))) + + +(provide 'org-num) +;;; org-num.el ends here diff --git a/lisp/org/org-pcomplete.el b/lisp/org/org-pcomplete.el index cf272de90a8..e557b1a117c 100644 --- a/lisp/org/org-pcomplete.el +++ b/lisp/org/org-pcomplete.el @@ -31,70 +31,126 @@ (require 'org-compat) (require 'pcomplete) -(declare-function org-make-org-heading-search-string "org" (&optional string)) -(declare-function org-get-buffer-tags "org" ()) -(declare-function org-get-tags "org" ()) -(declare-function org-buffer-property-keys "org" - (&optional specials defaults columns ignore-malformed)) +(declare-function org-at-heading-p "org" (&optional ignored)) +(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" ()) +(declare-function org-element-property "org-element" property element) +(declare-function org-element-type "org-element" (element)) +(declare-function org-end-of-meta-data "org" (&optional full)) (declare-function org-entry-properties "org" (&optional pom which)) +(declare-function org-export-backend-options "ox" (cl-x) t) +(declare-function org-get-buffer-tags "org" ()) +(declare-function org-get-export-keywords "org" ()) +(declare-function org-get-heading "org" (&optional no-tags no-todo no-priority no-comment)) +(declare-function org-get-tags "org" (&optional pos local)) +(declare-function org-link-heading-search-string "ol" (&optional string)) (declare-function org-tag-alist-to-string "org" (alist &optional skip-key)) -;;;; Customization variables - +(defvar org-current-tag-alist) +(defvar org-default-priority) (defvar org-drawer-regexp) +(defvar org-element-affiliated-keywords) +(defvar org-entities) +(defvar org-export-default-language) +(defvar org-export-exclude-tags) +(defvar org-export-select-tags) +(defvar org-file-tags) +(defvar org-highest-priority) +(defvar org-link-abbrev-alist) +(defvar org-link-abbrev-alist-local) +(defvar org-lowest-priority) +(defvar org-options-keywords) +(defvar org-outline-regexp) (defvar org-property-re) -(defvar org-current-tag-alist) +(defvar org-startup-options) +(defvar org-tag-re) +(defvar org-time-stamp-formats) +(defvar org-todo-keywords-1) +(defvar org-todo-line-regexp) + + +;;; Internal Functions (defun org-thing-at-point () "Examine the thing at point and let the caller know what it is. The return value is a string naming the thing at point." - (let ((beg1 (save-excursion - (skip-chars-backward "-[:alnum:]_@") - (point))) - (beg (save-excursion - (skip-chars-backward "-a-zA-Z0-9_:$") - (point))) - (line-to-here (buffer-substring (point-at-bol) (point)))) + (let ((line-to-here (org-current-line-string t)) + (case-fold-search t)) (cond - ((string-match "\\`[ \t]*#\\+begin: clocktable[ \t]+" line-to-here) + ;; Parameters on a clock table opening line. + ((org-match-line "[ \t]*#\\+BEGIN: clocktable[ \t]") (cons "block-option" "clocktable")) - ((string-match "\\`[ \t]*#\\+begin_src[ \t]+" line-to-here) + ;; Flags and parameters on a source block opening line. + ((org-match-line "[ \t]*#\\+BEGIN_SRC[ \t]") (cons "block-option" "src")) - ((save-excursion - (re-search-backward "^[ \t]*#\\+\\([A-Z_]+\\):.*" - (line-beginning-position) t)) + ;; Value for a known keyword. + ((org-match-line "[ \t]*#\\+\\(\\S-+\\):") (cons "file-option" (match-string-no-properties 1))) - ((string-match "\\`[ \t]*#\\+[a-zA-Z_]*\\'" line-to-here) + ;; Keyword name. + ((and (org-match-line "[ \t]*#\\+[a-zA-Z_]*$") + (looking-at-p "[ \t]*$")) (cons "file-option" nil)) - ((equal (char-before beg) ?\[) + ;; Link abbreviation. + ((save-excursion + (skip-chars-backward "-A-Za-z0-9_") + (and (eq ?\[ (char-before)) + (eq ?\[ (char-before (1- (point)))))) (cons "link" nil)) - ((equal (char-before beg) ?\\) + ;; Entities. Some of them accept numbers, but only at their end. + ;; So, we first skip numbers, then letters. + ((eq ?\\ (save-excursion + (skip-chars-backward "0-9") + (skip-chars-backward "a-zA-Z") + (char-before))) (cons "tex" nil)) - ((string-match "\\`\\*+[ \t]+\\'" - (buffer-substring (point-at-bol) beg)) + ;; Tags on a headline. + ((and (org-match-line + (format "\\*+ \\(?:.+? \\)?\\(:\\)\\(\\(?::\\|%s\\)+\\)?[ \t]*$" + org-tag-re)) + (or (org-point-in-group (point) 2) + (= (point) (match-end 1)))) + (cons "tag" nil)) + ;; TODO keywords on an empty headline. + ((and (string-match "^\\*+ +\\S-*$" line-to-here) + (looking-at-p "[ \t]*$")) (cons "todo" nil)) - ((equal (char-before beg) ?*) + ;; Heading after a star for search strings or links. + ((save-excursion + (skip-chars-backward "^*" (line-beginning-position)) + (and (eq ?* (char-before)) + (eq (char-before (1- (point))) '?\[) + (eq (char-before (- (point) 2)) '?\[))) (cons "searchhead" nil)) - ((and (equal (char-before beg1) ?:) - (equal (char-after (point-at-bol)) ?*)) - (cons "tag" nil)) - ((and (equal (char-before beg1) ?:) - (not (equal (char-after (point-at-bol)) ?*)) - (save-excursion - (move-beginning-of-line 1) - (skip-chars-backward " \t\n") - ;; org-drawer-regexp matches a whole line but while - ;; looking-back, we just ignore trailing whitespaces - (or (looking-back (substring org-drawer-regexp 0 -1) - (line-beginning-position)) - (looking-back org-property-re - (line-beginning-position))))) - (cons "prop" nil)) - ((and (equal (char-before beg1) ?:) - (not (equal (char-after (point-at-bol)) ?*))) - (cons "drawer" nil)) + ;; Property or drawer name, depending on point. If point is at + ;; a valid location for a node property, offer completion on all + ;; node properties in the buffer. Otherwise, offer completion on + ;; all drawer names, including "PROPERTIES". + ((and (string-match "^[ \t]*:\\S-*$" line-to-here) + (looking-at-p "[ \t]*$")) + (let ((origin (line-beginning-position))) + (if (org-before-first-heading-p) (cons "drawer" nil) + (save-excursion + (org-end-of-meta-data) + (if (or (= origin (point)) + (not (org-match-line "[ \t]*:PROPERTIES:[ \t]*$"))) + (cons "drawer" nil) + (while (org-match-line org-property-re) + (forward-line)) + (if (= origin (point)) (cons "prop" nil) + (cons "drawer" nil))))))) (t nil)))) +(defun org-pcomplete-case-double (list) + "Return list with both upcase and downcase version of all strings in LIST." + (let (e res) + (while (setq e (pop list)) + (setq res (cons (downcase e) (cons (upcase e) res)))) + (nreverse res))) + + +;;; Completion API + (defun org-command-at-point () "Return the qualified name of the Org completion entity at point. When completing for #+STARTUP, for example, this function returns @@ -133,9 +189,9 @@ When completing for #+STARTUP, for example, this function returns (car (org-thing-at-point))) pcomplete-default-completion-function)))) -(defvar org-options-keywords) ; From org.el -(defvar org-element-affiliated-keywords) ; From org-element.el -(declare-function org-get-export-keywords "org" ()) + +;;; Completion functions + (defun pcomplete/org-mode/file-option () "Complete against all valid file options." (require 'org-element) @@ -167,7 +223,6 @@ When completing for #+STARTUP, for example, this function returns "Complete arguments for the #+AUTHOR file option." (pcomplete-here (list user-full-name))) -(defvar org-time-stamp-formats) (defun pcomplete/org-mode/file-option/date () "Complete arguments for the #+DATE file option." (pcomplete-here (list (format-time-string (car org-time-stamp-formats))))) @@ -176,7 +231,6 @@ When completing for #+STARTUP, for example, this function returns "Complete arguments for the #+EMAIL file option." (pcomplete-here (list user-mail-address))) -(defvar org-export-exclude-tags) (defun pcomplete/org-mode/file-option/exclude_tags () "Complete arguments for the #+EXCLUDE_TAGS file option." (require 'ox) @@ -184,12 +238,10 @@ When completing for #+STARTUP, for example, this function returns (and org-export-exclude-tags (list (mapconcat 'identity org-export-exclude-tags " "))))) -(defvar org-file-tags) (defun pcomplete/org-mode/file-option/filetags () "Complete arguments for the #+FILETAGS file option." (pcomplete-here (and org-file-tags (mapconcat 'identity org-file-tags " ")))) -(defvar org-export-default-language) (defun pcomplete/org-mode/file-option/language () "Complete arguments for the #+LANGUAGE file option." (require 'ox) @@ -197,9 +249,6 @@ When completing for #+STARTUP, for example, this function returns (pcomplete-uniquify-list (list org-export-default-language "en")))) -(defvar org-default-priority) -(defvar org-highest-priority) -(defvar org-lowest-priority) (defun pcomplete/org-mode/file-option/priorities () "Complete arguments for the #+PRIORITIES file option." (pcomplete-here (list (format "%c %c %c" @@ -207,7 +256,6 @@ When completing for #+STARTUP, for example, this function returns org-lowest-priority org-default-priority)))) -(defvar org-export-select-tags) (defun pcomplete/org-mode/file-option/select_tags () "Complete arguments for the #+SELECT_TAGS file option." (require 'ox) @@ -215,7 +263,6 @@ When completing for #+STARTUP, for example, this function returns (and org-export-select-tags (list (mapconcat 'identity org-export-select-tags " "))))) -(defvar org-startup-options) (defun pcomplete/org-mode/file-option/startup () "Complete arguments for the #+STARTUP file option." (while (pcomplete-here @@ -244,7 +291,6 @@ When completing for #+STARTUP, for example, this function returns (buffer-name (buffer-base-buffer))))))) -(declare-function org-export-backend-options "ox" (cl-x) t) (defun pcomplete/org-mode/file-option/options () "Complete arguments for the #+OPTIONS file option." (while (pcomplete-here @@ -275,20 +321,18 @@ When completing for #+STARTUP, for example, this function returns "Complete arguments for the #+BIND file option, which are variable names." (let (vars) (mapatoms - (lambda (a) (if (boundp a) (setq vars (cons (symbol-name a) vars))))) + (lambda (a) (when (boundp a) (setq vars (cons (symbol-name a) vars))))) (pcomplete-here vars))) -(defvar org-link-abbrev-alist-local) -(defvar org-link-abbrev-alist) (defun pcomplete/org-mode/link () "Complete against defined #+LINK patterns." (pcomplete-here (pcomplete-uniquify-list (copy-sequence - (append (mapcar 'car org-link-abbrev-alist-local) - (mapcar 'car org-link-abbrev-alist)))))) + (mapcar (lambda (e) (concat (car e) ":")) + (append org-link-abbrev-alist-local + org-link-abbrev-alist)))))) -(defvar org-entities) (defun pcomplete/org-mode/tex () "Complete against TeX-style HTML entity names." (require 'org-entities) @@ -296,27 +340,24 @@ When completing for #+STARTUP, for example, this function returns (pcomplete-uniquify-list (remove nil (mapcar 'car-safe org-entities))) (substring pcomplete-stub 1)))) -(defvar org-todo-keywords-1) (defun pcomplete/org-mode/todo () "Complete against known TODO keywords." (pcomplete-here (pcomplete-uniquify-list (copy-sequence org-todo-keywords-1)))) -(defvar org-todo-line-regexp) (defun pcomplete/org-mode/searchhead () "Complete against all headings. This needs more work, to handle headings with lots of spaces in them." - (while - (pcomplete-here - (save-excursion - (goto-char (point-min)) - (let (tbl) - (let ((case-fold-search nil)) - (while (re-search-forward org-todo-line-regexp nil t) - (push (org-make-org-heading-search-string - (match-string-no-properties 3)) - tbl))) - (pcomplete-uniquify-list tbl))) - (substring pcomplete-stub 1)))) + (while (pcomplete-here + (save-excursion + (goto-char (point-min)) + (let (tbl) + (while (re-search-forward org-outline-regexp nil t) + (push (org-link-heading-search-string (org-get-heading t t t t)) + tbl)) + (pcomplete-uniquify-list tbl))) + ;; When completing a bracketed link, i.e., "[[*", argument + ;; starts at the star, so remove this character. + (substring pcomplete-stub 1)))) (defun pcomplete/org-mode/tag () "Complete a tag name. Omit tags already set." @@ -328,28 +369,47 @@ This needs more work, to handle headings with lots of spaces in them." (mapcar (lambda (x) (org-string-nw-p (car x))) org-current-tag-alist)) (mapcar #'car (org-get-buffer-tags)))))) - (dolist (tag (org-get-tags)) + (dolist (tag (org-get-tags nil t)) (setq lst (delete tag lst))) lst)) (and (string-match ".*:" pcomplete-stub) - (substring pcomplete-stub (match-end 0)))))) + (substring pcomplete-stub (match-end 0))) + t))) + +(defun pcomplete/org-mode/drawer () + "Complete a drawer name, including \"PROPERTIES\"." + (pcomplete-here + (org-pcomplete-case-double + (mapcar (lambda (x) (concat x ":")) + (let ((names (list "PROPERTIES"))) + (save-excursion + (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)) + (push (org-element-property :drawer-name drawer) names) + (goto-char (org-element-property :end drawer)))))) + (pcomplete-uniquify-list names)))) + (substring pcomplete-stub 1))) ;remove initial colon (defun pcomplete/org-mode/prop () "Complete a property name. Omit properties already set." (pcomplete-here - (mapcar (lambda (x) - (concat x ": ")) - (let ((lst (pcomplete-uniquify-list - (copy-sequence - (org-buffer-property-keys nil t t t))))) - (dolist (prop (org-entry-properties)) - (setq lst (delete (car prop) lst))) - lst)) + (org-pcomplete-case-double + (mapcar (lambda (x) + (concat x ": ")) + (let ((lst (pcomplete-uniquify-list + (copy-sequence (org-buffer-property-keys nil t t))))) + (dolist (prop (org-entry-properties)) + (setq lst (delete (car prop) lst))) + lst))) (substring pcomplete-stub 1))) (defun pcomplete/org-mode/block-option/src () - "Complete the arguments of a begin_src block. -Complete a language in the first field, the header arguments and switches." + "Complete the arguments of a source block. +Complete a language in the first field, the header arguments and +switches." (pcomplete-here (mapcar (lambda(x) (symbol-name (nth 3 x))) @@ -369,17 +429,12 @@ Complete a language in the first field, the header arguments and switches." ":tstart" ":tend" ":block" ":step" ":stepskip0" ":fileskip0" ":emphasize" ":link" ":narrow" ":indent" - ":tcolumns" ":level" ":compact" ":timestamp" - ":formula" ":formatter" ":wstart" ":mstart")))) - -(defun org-pcomplete-case-double (list) - "Return list with both upcase and downcase version of all strings in LIST." - (let (e res) - (while (setq e (pop list)) - (setq res (cons (downcase e) (cons (upcase e) res)))) - (nreverse res))) + ":hidefiles" ":tcolumns" ":level" ":compact" + ":timestamp" ":formula" ":formatter" + ":wstart" ":mstart")))) -;;;; Finish up + +;;; Finish up (provide 'org-pcomplete) diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el index a5635e326d4..4e84dbe09cc 100644 --- a/lisp/org/org-plot.el +++ b/lisp/org/org-plot.el @@ -131,7 +131,7 @@ Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE." "Export the data in TABLE to DATA-FILE for gnuplot. This means in a format appropriate for grid plotting by gnuplot. PARAMS specifies which columns of TABLE should be plotted as independent -and dependant variables." +and dependent variables." (interactive) (let* ((ind (- (plist-get params :ind) 1)) (deps (if (plist-member params :deps) diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el index 016105ef53b..44c6abbd959 100644 --- a/lisp/org/org-protocol.el +++ b/lisp/org/org-protocol.el @@ -116,12 +116,14 @@ ;;; Code: (require 'org) +(require 'ol) (declare-function org-publish-get-project-from-filename "ox-publish" (filename &optional up)) (declare-function server-edit "server" (&optional arg)) (defvar org-capture-link-is-already-stored) +(defvar org-capture-templates) (defgroup org-protocol nil "Intercept calls from emacsclient to trigger custom actions. @@ -297,11 +299,9 @@ SEPARATOR is specified or SEPARATOR is nil, assume \"/+\". The results of that splitting are returned as a list." (let* ((sep (or separator "/+\\|\\?")) (split-parts (split-string data sep))) - (if unhexify - (if (fboundp unhexify) - (mapcar unhexify split-parts) - (mapcar 'org-link-unescape split-parts)) - split-parts))) + (cond ((not unhexify) split-parts) + ((fboundp unhexify) (mapcar unhexify split-parts)) + (t (mapcar #'org-link-decode split-parts))))) (defun org-protocol-flatten-greedy (param-list &optional strip-path replacement) "Transform PARAM-LIST into a flat list for greedy handlers. @@ -381,11 +381,8 @@ If INFO is already a property list, return it unchanged." result) (while data (setq result - (append - result - (list - (pop data) - (org-link-unescape (pop data)))))) + (append result + (list (pop data) (org-link-decode (pop data)))))) result) (let ((data (org-protocol-split-data info t org-protocol-data-separator))) (if default-order @@ -444,9 +441,9 @@ form URL/TITLE can also be used." (when (boundp 'org-stored-links) (push (list uri title) org-stored-links)) (kill-new uri) - (message "`%s' to insert new org-link, `%s' to insert `%s'" - (substitute-command-keys "`\\[org-insert-link]'") - (substitute-command-keys "`\\[yank]'") + (message "`%s' to insert new Org link, `%s' to insert %S" + (substitute-command-keys "\\[org-insert-link]") + (substitute-command-keys "\\[yank]") uri)) nil) @@ -471,51 +468,53 @@ You may specify the template with a template= query parameter, like this: javascript:location.href = \\='org-protocol://capture?template=b\\='+ ... Now template ?b will be used." - (if (and (boundp 'org-stored-links) - (org-protocol-do-capture info)) - (message "Item captured.")) - nil) - -(defun org-protocol-convert-query-to-plist (query) - "Convert QUERY key=value pairs in the URL to a property list." - (if query - (apply 'append (mapcar (lambda (x) - (let ((c (split-string x "="))) - (list (intern (concat ":" (car c))) (cadr c)))) - (split-string query "&"))))) - -(defun org-protocol-do-capture (info) - "Perform the actual capture based on INFO." - (let* ((temp-parts (org-protocol-parse-parameters info)) - (parts - (cond - ((and (listp info) (symbolp (car info))) info) - ((= (length (car temp-parts)) 1) ;; First parameter is exactly one character long - (org-protocol-assign-parameters temp-parts '(:template :url :title :body))) - (t - (org-protocol-assign-parameters temp-parts '(:url :title :body))))) + (let* ((parts + (pcase (org-protocol-parse-parameters info) + ;; New style links are parsed as a plist. + ((let `(,(pred keywordp) . ,_) info) info) + ;; Old style links, with or without template key, are + ;; parsed as a list of strings. + (p + (let ((k (if (= 1 (length (car p))) + '(:template :url :title :body) + '(:url :title :body)))) + (org-protocol-assign-parameters p k))))) (template (or (plist-get parts :template) org-protocol-default-template-key)) - (url (and (plist-get parts :url) (org-protocol-sanitize-uri (plist-get parts :url)))) - (type (and url (if (string-match "^\\([a-z]+\\):" url) - (match-string 1 url)))) + (url (and (plist-get parts :url) + (org-protocol-sanitize-uri (plist-get parts :url)))) + (type (and url + (string-match "^\\([a-z]+\\):" url) + (match-string 1 url))) (title (or (plist-get parts :title) "")) (region (or (plist-get parts :body) "")) - (orglink (if url - (org-make-link-string - url (if (string-match "[^[:space:]]" title) title url)) - title)) - (org-capture-link-is-already-stored t)) ;; avoid call to org-store-link - (setq org-stored-links - (cons (list url title) org-stored-links)) - (org-store-link-props :type type + (orglink + (if (null url) title + (org-link-make-string url (or (org-string-nw-p title) url)))) + ;; Avoid call to `org-store-link'. + (org-capture-link-is-already-stored t)) + ;; Only store link if there's a URL to insert later on. + (when url (push (list url title) org-stored-links)) + (org-link-store-props :type type :link url :description title :annotation orglink :initial region :query parts) (raise-frame) - (funcall 'org-capture nil template))) + (org-capture nil template) + (message "Item captured.") + ;; Make sure we do not return a string, as `server-visit-files', + ;; through `server-edit', would interpret it as a file name. + nil)) + +(defun org-protocol-convert-query-to-plist (query) + "Convert QUERY key=value pairs in the URL to a property list." + (when query + (apply 'append (mapcar (lambda (x) + (let ((c (split-string x "="))) + (list (intern (concat ":" (car c))) (cadr c)))) + (split-string query "&"))))) (defun org-protocol-open-source (fname) "Process an org-protocol://open-source?url= style URL with FNAME. diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el index d8f2cefe181..5e50a1b47cb 100644 --- a/lisp/org/org-src.el +++ b/lisp/org/org-src.el @@ -32,13 +32,11 @@ ;;; Code: (require 'cl-lib) +(require 'ob-comint) (require 'org-macs) (require 'org-compat) -(require 'ob-keys) -(require 'ob-comint) +(require 'org-keys) -(declare-function org-base-buffer "org" (buffer)) -(declare-function org-do-remove-indentation "org" (&optional n)) (declare-function org-element-at-point "org-element" ()) (declare-function org-element-class "org-element" (datum &optional parent)) (declare-function org-element-context "org-element" (&optional element)) @@ -48,9 +46,6 @@ (declare-function org-element-type "org-element" (element)) (declare-function org-footnote-goto-definition "org-footnote" (label &optional location)) -(declare-function org-get-indentation "org" (&optional line)) -(declare-function org-switch-to-buffer-other-window "org" (&rest args)) -(declare-function org-trim "org" (s &optional keep-lead)) (defvar org-inhibit-startup) @@ -128,7 +123,8 @@ editing it with `\\[org-edit-src-code]'. It has no effect if `org-src-preserve-indentation' is non-nil." :group 'org-edit-structure - :type 'integer) + :type 'integer + :safe #'wholenump) (defcustom org-edit-src-persistent-message t "Non-nil means show persistent exit help message while editing src examples. @@ -152,17 +148,23 @@ the existing edit buffer." "How the source code edit buffer should be displayed. Possible values for this option are: -current-window Show edit buffer in the current window, keeping all other - windows. -other-window Use `switch-to-buffer-other-window' to display edit buffer. -reorganize-frame Show only two windows on the current frame, the current - window and the edit buffer. When exiting the edit buffer, - return to one window. -other-frame Use `switch-to-buffer-other-frame' to display edit buffer. - Also, when exiting the edit buffer, kill that frame." +current-window Show edit buffer in the current window, keeping all other + windows. +split-window-below Show edit buffer below the current window, keeping all + other windows. +split-window-right Show edit buffer to the right of the current window, + keeping all other windows. +other-window Use `switch-to-buffer-other-window' to display edit buffer. +reorganize-frame Show only two windows on the current frame, the current + window and the edit buffer. When exiting the edit buffer, + return to one window. +other-frame Use `switch-to-buffer-other-frame' to display edit buffer. + Also, when exiting the edit buffer, kill that frame." :group 'org-edit-structure :type '(choice (const current-window) + (const split-window-below) + (const split-window-right) (const other-frame) (const other-window) (const reorganize-frame))) @@ -179,17 +181,29 @@ or similar things which you want to have when editing a source code file, but which mess up the display of a snippet in Org exported files.") (defcustom org-src-lang-modes - '(("ocaml" . tuareg) ("elisp" . emacs-lisp) ("ditaa" . artist) - ("asymptote" . asy) ("dot" . fundamental) ("sqlite" . sql) - ("calc" . fundamental) ("C" . c) ("cpp" . c++) ("C++" . c++) - ("screen" . shell-script) ("shell" . sh) ("bash" . sh)) + '(("C" . c) + ("C++" . c++) + ("asymptote" . asy) + ("bash" . sh) + ("beamer" . latex) + ("calc" . fundamental) + ("cpp" . c++) + ("ditaa" . artist) + ("dot" . fundamental) + ("elisp" . emacs-lisp) + ("ocaml" . tuareg) + ("screen" . shell-script) + ("shell" . sh) + ("sqlite" . sql)) "Alist mapping languages to their major mode. -The key is the language name, the value is the string that should -be inserted as the name of the major mode. For many languages this is -simple, but for language where this is not the case, this variable -provides a way to simplify things on the user side. -For example, there is no ocaml-mode in Emacs, but the mode to use is -`tuareg-mode'." + +The key is the language name. The value is the mode name, as +a string or a symbol, without the \"-mode\" suffix. + +For many languages this is simple, but for language where this is +not the case, this variable provides a way to simplify things on +the user side. For example, there is no `ocaml-mode' in Emacs, +but the mode to use is `tuareg-mode'." :group 'org-edit-structure :type '(repeat (cons @@ -229,23 +243,52 @@ issued in the language major mode buffer." ;;; Internal functions and variables -(defvar org-src--allow-write-back t) -(defvar org-src--auto-save-timer nil) -(defvar org-src--babel-info nil) -(defvar org-src--beg-marker nil) -(defvar org-src--block-indentation nil) -(defvar org-src--end-marker nil) -(defvar org-src--from-org-mode nil) -(defvar org-src--overlay nil) -(defvar org-src--preserve-indentation nil) -(defvar org-src--remote nil) -(defvar org-src--saved-temp-window-config nil) -(defvar org-src--source-type nil +(defvar org-src--auto-save-timer nil + "Idle Timer auto-saving remote editing buffers.") + +(defvar-local org-src--allow-write-back t) +(put 'org-src--allow-write-back 'permanent-local t) + +(defvar-local org-src--babel-info nil) +(put 'org-src--babel-info 'permanent-local t) + +(defvar-local org-src--beg-marker nil) +(put 'org-src--beg-marker 'permanent-local t) + +(defvar-local org-src--block-indentation nil) +(put 'org-src--block-indentation 'permanent-local t) + +(defvar-local org-src--content-indentation nil) +(put 'org-src--content-indentation 'permanent-local t) + +(defvar-local org-src--end-marker nil) +(put 'org-src--end-marker 'permanent-local t) + +(defvar-local org-src--from-org-mode nil) +(put 'org-src--from-org-mode 'permanent-local t) + +(defvar-local org-src--overlay nil) +(put 'org-src--overlay 'permanent-local t) + +(defvar-local org-src--preserve-indentation nil) +(put 'org-src--preserve-indentation 'permanent-local t) + +(defvar-local org-src--remote nil) +(put 'org-src--remote 'permanent-local t) + +(defvar-local org-src--source-type nil "Type of element being edited, as a symbol.") -(defvar org-src--tab-width nil +(put 'org-src--source-type 'permanent-local t) + +(defvar-local org-src--tab-width nil "Contains `tab-width' value from Org source buffer. However, if `indent-tabs-mode' is nil in that buffer, its value is 0.") +(put 'org-src--tab-width 'permanent-local t) + +(defvar-local org-src-source-file-name nil + "File name associated to Org source buffer, or nil.") +(put 'org-src-source-file-name 'permanent-local t) (defun org-src--construct-edit-buffer-name (org-buffer-name lang) "Construct the buffer name for a source editing buffer." @@ -264,21 +307,6 @@ Return nil if there is no such buffer." (eq (marker-buffer end) (marker-buffer org-src--end-marker)) (throw 'exit b)))))) -(defun org-src--source-buffer () - "Return source buffer edited by current buffer." - (unless (org-src-edit-buffer-p) (error "Not in a source buffer")) - (or (marker-buffer org-src--beg-marker) - (error "No source buffer available for current editing session"))) - -(defun org-src--get-lang-mode (lang) - "Return major mode that should be used for LANG. -LANG is a string, and the returned major mode is a symbol." - (intern - (concat - (let ((l (or (cdr (assoc lang org-src-lang-modes)) lang))) - (if (symbolp l) (symbol-name l) l)) - "-mode"))) - (defun org-src--coordinates (pos beg end) "Return coordinates of POS relatively to BEG and END. POS, BEG and END are buffer positions. Return value is either @@ -397,7 +425,7 @@ Assume point is in the corresponding edit buffer." (if org-src--preserve-indentation 0 (+ (or org-src--block-indentation 0) (if (memq org-src--source-type '(example-block src-block)) - org-edit-src-content-indentation + org-src--content-indentation 0)))) (use-tabs? (and (> org-src--tab-width 0) t)) (source-tab-width org-src--tab-width) @@ -405,8 +433,8 @@ Assume point is in the corresponding edit buffer." (write-back org-src--allow-write-back)) (with-temp-buffer ;; Reproduce indentation parameters from source buffer. - (setq-local indent-tabs-mode use-tabs?) - (when (> source-tab-width 0) (setq-local tab-width source-tab-width)) + (setq indent-tabs-mode use-tabs?) + (when (> source-tab-width 0) (setq tab-width source-tab-width)) ;; Apply WRITE-BACK function on edit buffer contents. (insert (org-no-properties contents)) (goto-char (point-min)) @@ -441,7 +469,6 @@ When REMOTE is non-nil, do not try to preserve point or mark when moving from the edit area to the source. Leave point in edit buffer." - (setq org-src--saved-temp-window-config (current-window-configuration)) (let* ((area (org-src--contents-area datum)) (beg (copy-marker (nth 0 area))) (end (copy-marker (nth 1 area) t)) @@ -457,11 +484,12 @@ Leave point in edit buffer." (with-current-buffer old-edit-buffer (org-src--remove-overlay)) (kill-buffer old-edit-buffer)) (let* ((org-mode-p (derived-mode-p 'org-mode)) + (source-file-name (buffer-file-name (buffer-base-buffer))) (source-tab-width (if indent-tabs-mode tab-width 0)) (type (org-element-type datum)) - (ind (org-with-wide-buffer - (goto-char (org-element-property :begin datum)) - (org-get-indentation))) + (block-ind (org-with-point-at (org-element-property :begin datum) + (current-indentation))) + (content-ind org-edit-src-content-indentation) (preserve-ind (and (memq type '(example-block src-block)) (or (org-element-property :preserve-indent datum) @@ -498,16 +526,18 @@ Leave point in edit buffer." ;; Transmit buffer-local variables for exit function. It must ;; be done after initializing major mode, as this operation ;; may reset them otherwise. - (setq-local org-src--tab-width source-tab-width) - (setq-local org-src--from-org-mode org-mode-p) - (setq-local org-src--beg-marker beg) - (setq-local org-src--end-marker end) - (setq-local org-src--remote remote) - (setq-local org-src--source-type type) - (setq-local org-src--block-indentation ind) - (setq-local org-src--preserve-indentation preserve-ind) - (setq-local org-src--overlay overlay) - (setq-local org-src--allow-write-back write-back) + (setq org-src--tab-width source-tab-width) + (setq org-src--from-org-mode org-mode-p) + (setq org-src--beg-marker beg) + (setq org-src--end-marker end) + (setq org-src--remote remote) + (setq org-src--source-type type) + (setq org-src--block-indentation block-ind) + (setq org-src--content-indentation content-ind) + (setq org-src--preserve-indentation preserve-ind) + (setq org-src--overlay overlay) + (setq org-src--allow-write-back write-back) + (setq org-src-source-file-name source-file-name) ;; Start minor mode. (org-src-mode) ;; Move mark and point in edit buffer to the corresponding @@ -536,7 +566,7 @@ Leave point in edit buffer." "Fontify code block. This function is called by emacs automatic fontification, as long as `org-src-fontify-natively' is non-nil." - (let ((lang-mode (org-src--get-lang-mode lang))) + (let ((lang-mode (org-src-get-lang-mode lang))) (when (fboundp lang-mode) (let ((string (buffer-substring-no-properties start end)) (modified (buffer-modified-p)) @@ -631,13 +661,12 @@ This minor mode is turned on in two situations: See also `org-src-mode-hook'." nil " OrgSrc" nil (when org-edit-src-persistent-message - (setq-local - header-line-format - (substitute-command-keys - (if org-src--allow-write-back - "Edit, then exit with `\\[org-edit-src-exit]' or abort with \ + (setq header-line-format + (substitute-command-keys + (if org-src--allow-write-back + "Edit, then exit with `\\[org-edit-src-exit]' or abort with \ `\\[org-edit-src-abort]'" - "Exit with `\\[org-edit-src-exit]' or abort with \ + "Exit with `\\[org-edit-src-exit]' or abort with \ `\\[org-edit-src-abort]'")))) ;; Possibly activate various auto-save features (for the edit buffer ;; or the source buffer). @@ -646,7 +675,8 @@ See also `org-src-mode-hook'." (concat (make-temp-name "org-src-") (format-time-string "-%Y-%d-%m") ".txt"))) - (unless (or org-src--auto-save-timer (zerop org-edit-src-auto-save-idle-delay)) + (unless (or org-src--auto-save-timer + (= 0 org-edit-src-auto-save-idle-delay)) (setq org-src--auto-save-timer (run-with-idle-timer org-edit-src-auto-save-idle-delay t @@ -663,15 +693,13 @@ See also `org-src-mode-hook'." (setq org-src--auto-save-timer nil))))))))) (defun org-src-mode-configure-edit-buffer () + "Configure the src edit buffer." (when (bound-and-true-p org-src--from-org-mode) (add-hook 'kill-buffer-hook #'org-src--remove-overlay nil 'local) (if (bound-and-true-p org-src--allow-write-back) (progn (setq buffer-offer-save t) - (setq buffer-file-name - (concat (buffer-file-name (marker-buffer org-src--beg-marker)) - "[" (buffer-name) "]")) - (setq-local write-contents-functions '(org-edit-src-save))) + (setq write-contents-functions '(org-edit-src-save))) (setq buffer-read-only t)))) (add-hook 'org-src-mode-hook #'org-src-mode-configure-edit-buffer) @@ -732,6 +760,15 @@ Org-babel commands." (org-src-do-at-code-block (call-interactively (lookup-key org-babel-map key))))) +(defun org-src-get-lang-mode (lang) + "Return major mode that should be used for LANG. +LANG is a string, and the returned major mode is a symbol." + (intern + (concat + (let ((l (or (cdr (assoc lang org-src-lang-modes)) lang))) + (if (symbolp l) (symbol-name l) l)) + "-mode"))) + (defun org-src-edit-buffer-p (&optional buffer) "Non-nil when current buffer is a source editing buffer. If BUFFER is non-nil, test it instead." @@ -740,11 +777,34 @@ If BUFFER is non-nil, test it instead." (local-variable-p 'org-src--beg-marker buffer) (local-variable-p 'org-src--end-marker buffer)))) +(defun org-src-source-buffer () + "Return source buffer edited in current buffer. +Raise an error when current buffer is not a source editing buffer." + (unless (org-src-edit-buffer-p) (error "Not in a source buffer")) + (or (marker-buffer org-src--beg-marker) + (error "No source buffer available for current editing session"))) + +(defun org-src-source-type () + "Return type of element edited in current buffer. +Raise an error when current buffer is not a source editing buffer." + (unless (org-src-edit-buffer-p) (error "Not in a source buffer")) + org-src--source-type) + (defun org-src-switch-to-buffer (buffer context) (pcase org-src-window-setup (`current-window (pop-to-buffer-same-window buffer)) (`other-window (switch-to-buffer-other-window buffer)) + (`split-window-below + (if (eq context 'exit) + (delete-window) + (select-window (split-window-vertically))) + (pop-to-buffer-same-window buffer)) + (`split-window-right + (if (eq context 'exit) + (delete-window) + (select-window (split-window-horizontally))) + (pop-to-buffer-same-window buffer)) (`other-frame (pcase context (`exit @@ -900,7 +960,7 @@ the LaTeX environment in the Org mode buffer." (org-src--edit-element element (org-src--construct-edit-buffer-name (buffer-name) "LaTeX environment") - (org-src--get-lang-mode "latex") + (org-src-get-lang-mode "latex") t) t)) @@ -925,7 +985,7 @@ Throw an error when not at an export block." ;; Missing export-block type. Fallback ;; to default mode. "fundamental"))) - (mode (org-src--get-lang-mode type))) + (mode (org-src-get-lang-mode type))) (unless (functionp mode) (error "No such language mode: %s" mode)) (org-src--edit-element element @@ -958,7 +1018,7 @@ name of the sub-editing buffer." (let* ((lang (if (eq type 'src-block) (org-element-property :language element) "example")) - (lang-f (and (eq type 'src-block) (org-src--get-lang-mode lang))) + (lang-f (and (eq type 'src-block) (org-src-get-lang-mode lang))) (babel-info (and (eq type 'src-block) (org-babel-get-src-block-info 'light))) deactivate-mark) @@ -977,7 +1037,7 @@ name of the sub-editing buffer." (or (org-element-property :label-fmt element) org-coderef-label-format)) (when (eq type 'src-block) - (setq-local org-src--babel-info babel-info) + (setq org-src--babel-info babel-info) (let ((edit-prep-func (intern (concat "org-babel-edit-prep:" lang)))) (when (fboundp edit-prep-func) (funcall edit-prep-func babel-info)))) @@ -991,7 +1051,7 @@ name of the sub-editing buffer." (org-src--on-datum-p context)) (user-error "Not on inline source code")) (let* ((lang (org-element-property :language context)) - (lang-f (org-src--get-lang-mode lang)) + (lang-f (org-src-get-lang-mode lang)) (babel-info (org-babel-get-src-block-info 'light)) deactivate-mark) (unless (functionp lang-f) (error "No such language mode: %s" lang-f)) @@ -1000,7 +1060,7 @@ name of the sub-editing buffer." (org-src--construct-edit-buffer-name (buffer-name) lang) lang-f (lambda () - ;; Inline src blocks are limited to one line. + ;; Inline source blocks are limited to one line. (while (re-search-forward "\n[ \t]*" nil t) (replace-match " ")) ;; Trim contents. (goto-char (point-min)) @@ -1010,8 +1070,8 @@ name of the sub-editing buffer." (skip-chars-backward " \t") (delete-region (point) (point-max)))) ;; Finalize buffer. - (setq-local org-src--babel-info babel-info) - (setq-local org-src--preserve-indentation t) + (setq org-src--babel-info babel-info) + (setq org-src--preserve-indentation t) (let ((edit-prep-func (intern (concat "org-babel-edit-prep:" lang)))) (when (fboundp edit-prep-func) (funcall edit-prep-func babel-info))) ;; Return success. @@ -1066,7 +1126,7 @@ Throw an error if there is no such buffer." (beg org-src--beg-marker) (end org-src--end-marker) (overlay org-src--overlay)) - (with-current-buffer (org-src--source-buffer) + (with-current-buffer (org-src-source-buffer) (undo-boundary) (goto-char beg) ;; Temporarily disable read-only features of OVERLAY in order to @@ -1122,10 +1182,7 @@ Throw an error if there is no such buffer." (write-back (org-src--goto-coordinates coordinates beg end)))) ;; Clean up left-over markers and restore window configuration. (set-marker beg nil) - (set-marker end nil) - (when org-src--saved-temp-window-config - (set-window-configuration org-src--saved-temp-window-config) - (setq org-src--saved-temp-window-config nil)))) + (set-marker end nil))) (provide 'org-src) diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index a65629b302c..a21587acbe0 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -35,51 +35,66 @@ ;;; Code: (require 'cl-lib) -(require 'org) +(require 'org-macs) +(require 'org-compat) +(require 'org-keys) +(declare-function calc-eval "calc" (str &optional separator &rest args)) +(declare-function org-at-timestamp-p "org" (&optional extended)) +(declare-function org-delete-backward-char "org" (N)) (declare-function org-element-at-point "org-element" ()) (declare-function org-element-contents "org-element" (element)) (declare-function org-element-extract-element "org-element" (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-map "org-element" - (data types fun - &optional info first-match no-recursion with-affiliated)) -(declare-function org-element-parse-buffer "org-element" - (&optional granularity visible-only)) +(declare-function org-element-lineage "org-element" (blob &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-parse-buffer "org-element" (&optional granularity visible-only)) (declare-function org-element-property "org-element" (property element)) (declare-function org-element-type "org-element" (element)) - +(declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) (declare-function org-export-create-backend "ox" (&rest rest) t) (declare-function org-export-data-with-backend "ox" (data backend info)) -(declare-function org-export-filter-apply-functions "ox" - (filters value info)) +(declare-function org-export-filter-apply-functions "ox" (filters value info)) (declare-function org-export-first-sibling-p "ox" (blob info)) (declare-function org-export-get-backend "ox" (name)) -(declare-function org-export-get-environment "ox" - (&optional backend subtreep ext-plist)) +(declare-function org-export-get-environment "ox" (&optional backend subtreep ext-plist)) (declare-function org-export-install-filters "ox" (info)) (declare-function org-export-table-has-special-column-p "ox" (table)) (declare-function org-export-table-row-is-special-p "ox" (table-row info)) - -(declare-function calc-eval "calc" (str &optional separator &rest args)) +(declare-function org-id-find "org-id" (id &optional markerp)) +(declare-function org-indent-line "org" ()) +(declare-function org-load-modules-maybe "org" (&optional force)) +(declare-function org-restart-font-lock "org" ()) +(declare-function org-sort-remove-invisible "org" (s)) +(declare-function org-time-stamp-format "org" (&optional long inactive)) +(declare-function org-time-string-to-absolute "org" (s &optional daynr prefer buffer pos)) +(declare-function org-time-string-to-time "org" (s)) +(declare-function org-timestamp-up-day "org" (&optional arg)) (defvar constants-unit-system) +(defvar org-M-RET-may-split-line) (defvar org-element-use-cache) (defvar org-export-filters-alist) -(defvar org-table-follow-field-mode) -(defvar orgtbl-mode) ; defined below -(defvar orgtbl-mode-menu) ; defined when orgtbl mode get initialized +(defvar org-finish-function) +(defvar org-inhibit-highlight-removal) +(defvar org-inhibit-startup) +(defvar org-selected-window) +(defvar org-self-insert-cluster-for-undo) +(defvar org-self-insert-command-undo-counter) +(defvar org-ts-regexp) +(defvar org-ts-regexp-both) +(defvar org-ts-regexp-inactive) +(defvar org-ts-regexp3) +(defvar org-window-configuration) (defvar sort-fold-case) -(defvar orgtbl-after-send-table-hook nil - "Hook for functions attaching to `C-c C-c', if the table is sent. -This can be used to add additional functionality after the table is sent -to the receiver position, otherwise, if table is not sent, the functions -are not run.") + +;;; Customizables -(defvar org-table-TBLFM-begin-regexp "^[ \t]*|.*\n[ \t]*#\\+TBLFM: ") +(defgroup org-table nil + "Options concerning tables in Org mode." + :tag "Org Table" + :group 'org) (defcustom orgtbl-optimized t "Non-nil means use the optimized table editor version for `orgtbl-mode'. @@ -193,6 +208,15 @@ alignment to the right border applies." :group 'org-table-settings :type 'number) +(defcustom org-table-formula-field-format "%s" + "Format for fields which contain the result of a formula. +For example, using \"~%s~\" will display the result within tilde +characters. Beware that modifying the display can prevent the +field from being used in another formula." + :group 'org-table-settings + :version "24.1" + :type 'string) + (defgroup org-table-editing nil "Behavior of tables during editing in Org mode." :tag "Org Table Editing" @@ -231,9 +255,6 @@ fields." (const :tag "with yes-or-no" yes-or-no-p) (const :tag "with y-or-n" y-or-n-p) (const :tag "no confirmation" nil))) -(put 'org-table-fix-formulas-confirm - 'safe-local-variable - #'(lambda (x) (member x '(yes-or-no-p y-or-n-p)))) (defcustom org-table-tab-jumps-over-hlines t "Non-nil means tab in the last column of a table with jump over a hline. @@ -244,6 +265,13 @@ this line." :group 'org-table-editing :type 'boolean) +(defcustom org-table-shrunk-column-indicator "…" + "String to be displayed in a shrunk column." + :group 'org-table-editing + :type 'string + :package-version '(Org . "9.2") + :safe (lambda (v) (and (stringp v) (not (equal v ""))))) + (defgroup org-table-calculation nil "Options concerning tables in Org mode." :tag "Org Table Calculation" @@ -279,8 +307,7 @@ t accept as input and present for editing" calc-prefer-frac nil calc-symbolic-mode nil calc-date-format (YYYY "-" MM "-" DD " " Www (" " hh ":" mm)) - calc-display-working-message t - ) + calc-display-working-message t) "List with Calc mode settings for use in `calc-eval' for table formulas. The list must contain alternating symbols (Calc modes variables and values). Don't remove any of the default settings, just change the values. Org mode @@ -313,15 +340,6 @@ So this is about 08:32:34 versus 8:33:34." :type 'boolean :safe #'booleanp) -(defcustom org-table-formula-field-format "%s" - "Format for fields which contain the result of a formula. -For example, using \"~%s~\" will display the result within tilde -characters. Beware that modifying the display can prevent the -field from being used in another formula." - :group 'org-table-settings - :version "24.1" - :type 'string) - (defcustom org-table-formula-evaluate-inline t "Non-nil means TAB and RET evaluate a formula in current table field. If the current field starts with an equal sign, it is assumed to be a formula @@ -393,7 +411,6 @@ many columns as needed. When set to `warn', issue a warning when doing so. When set to `prompt', ask user before creating a new column. Otherwise, throw an error." :group 'org-table-calculation - :version "26.1" :package-version '(Org . "8.3") :type '(choice (const :tag "Out-of-bounds field generates an error (default)" nil) @@ -419,12 +436,38 @@ available parameters." "Max lines that `org-table-convert-region' will attempt to process. The function can be slow on larger regions; this safety feature -prevents it from hanging emacs." +prevents it from hanging Emacs." :group 'org-table-import-export :type 'integer - :version "26.1" :package-version '(Org . "8.3")) + +;;; Regexps Constants + +(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" + "Detect an org-type or table-type table.") + +(defconst org-table-line-regexp "^[ \t]*|" + "Detect an org-type table line.") + +(defconst org-table-dataline-regexp "^[ \t]*|[^-]" + "Detect an org-type table line.") + +(defconst org-table-hline-regexp "^[ \t]*|-" + "Detect an org-type table hline.") + +(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" + "Detect a table-type table hline.") + +(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" + "Detect the first line outside a table when searching from within it. +This works for both table types.") + +(defconst org-TBLFM-regexp "^[ \t]*#\\+TBLFM: " + "Detect a #+TBLFM line.") + +(defvar org-table-TBLFM-begin-regexp "^[ \t]*|.*\n[ \t]*#\\+TBLFM: ") + (defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)" "Regexp matching a line marked for automatic recalculation.") @@ -437,10 +480,52 @@ prevents it from hanging emacs." (defconst org-table-border-regexp "^[ \t]*[^| \t]" "Regexp matching any line outside an Org table.") +(defconst org-table-range-regexp + "@\\([-+]?I*[-+]?[0-9]*\\)\\(\\$[-+]?[0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)\\(\\$[-+]?[0-9]+\\)?\\)?" + ;; 1 2 3 4 5 + "Regular expression for matching ranges in formulas.") + +(defconst org-table-range-regexp2 + (concat + "\\(" "@[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)" + "\\.\\." + "\\(" "@?[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)") + "Match a range for reference display.") + +(defconst org-table-translate-regexp + (concat "\\(" "@[-0-9I$]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\)") + "Match a reference that needs translation, for reference display.") + +(defconst org-table-separator-space + (propertize " " 'display '(space :relative-width 1)) + "Space used around fields when aligning the table. +This space serves as a segment separator for the purposes of the +bidirectional reordering.") + + +;;; Internal Variables + (defvar org-table-last-highlighted-reference nil) (defvar org-table-formula-history nil) +(defvar org-field-marker nil) +(defvar org-table-buffer-is-an nil) + +(defvar-local org-table-formula-constants-local nil + "Local version of `org-table-formula-constants'.") + +(defvar org-table-may-need-update t + "Indicates that a table might need an update. +This variable is set by `org-before-change-function'. +`org-table-align' sets it back to nil.") + +(defvar orgtbl-after-send-table-hook nil + "Hook for functions attaching to `C-c C-c', if the table is sent. +This can be used to add additional functionality after the table is sent +to the receiver position, otherwise, if table is not sent, the functions +are not run.") + (defvar org-table-column-names nil "Alist with column names, derived from the `!' line. This variable is initialized with `org-table-analyze'.") @@ -483,21 +568,84 @@ variable is initialized with `org-table-analyze'.") Line numbers are counted from the beginning of the table. This variable is initialized with `org-table-analyze'.") -(defconst org-table-range-regexp - "@\\([-+]?I*[-+]?[0-9]*\\)\\(\\$[-+]?[0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)\\(\\$[-+]?[0-9]+\\)?\\)?" - ;; 1 2 3 4 5 - "Regular expression for matching ranges in formulas.") +(defvar org-table-aligned-begin-marker (make-marker) + "Marker at the beginning of the table last aligned. +Used to check if cursor still is in that table, to minimize realignment.") -(defconst org-table-range-regexp2 - (concat - "\\(" "@[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)" - "\\.\\." - "\\(" "@?[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)") - "Match a range for reference display.") +(defvar org-table-aligned-end-marker (make-marker) + "Marker at the end of the table last aligned. +Used to check if cursor still is in that table, to minimize realignment.") -(defconst org-table-translate-regexp - (concat "\\(" "@[-0-9I$]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\)") - "Match a reference that needs translation, for reference display.") +(defvar org-table-last-alignment nil + "List of flags for flushright alignment, from the last re-alignment. +This is being used to correctly align a single field after TAB or RET.") + +(defvar org-table-last-column-widths nil + "List of max width of fields in each column. +This is being used to correctly align a single field after TAB or RET.") + +(defvar-local org-table-formula-debug nil + "Non-nil means debug table formulas. +When nil, simply write \"#ERROR\" in corrupted fields.") + +(defvar-local org-table-overlay-coordinates nil + "Overlay coordinates after each align of a table.") + +(defvar org-last-recalc-line nil) + +(defvar org-show-positions nil) + +(defvar org-table-rectangle-overlays nil) + +(defvar org-table-clip nil + "Clipboard for table regions.") + +(defvar org-timecnt nil) + +(defvar org-recalc-commands nil + "List of commands triggering the recalculation of a line. +Will be filled automatically during use.") + +(defvar org-recalc-marks + '((" " . "Unmarked: no special line, no automatic recalculation") + ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") + ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") + ("!" . "Column name definition line. Reference in formula as $name.") + ("$" . "Parameter definition line name=value. Reference in formula as $name.") + ("_" . "Names for values in row below this one.") + ("^" . "Names for values in row above this one."))) + +(defvar org-tbl-calc-modes nil) + +(defvar org-pos nil) + + +;;; Macros and Inlined Functions + +(defmacro org-table-with-shrunk-columns (&rest body) + "Expand all columns before executing BODY, then shrink them again." + (declare (debug (body))) + (org-with-gensyms (shrunk-columns begin end) + `(let ((,begin (copy-marker (org-table-begin))) + (,end (copy-marker (org-table-end) t)) + (,shrunk-columns (org-table--list-shrunk-columns))) + (org-with-point-at ,begin (org-table-expand ,begin ,end)) + (unwind-protect + (progn ,@body) + (org-table--shrink-columns ,shrunk-columns ,begin ,end) + (set-marker ,begin nil) + (set-marker ,end nil))))) + +(defmacro org-table-with-shrunk-field (&rest body) + "Save field shrunk state, execute BODY and restore state." + (declare (debug (body))) + (org-with-gensyms (end shrunk size) + `(let* ((,shrunk (save-match-data (org-table--shrunk-field))) + (,end (and ,shrunk (copy-marker (overlay-end ,shrunk) t))) + (,size (and ,shrunk (- ,end (overlay-start ,shrunk))))) + (when ,shrunk (delete-overlay ,shrunk)) + (unwind-protect (progn ,@body) + (when ,shrunk (move-overlay ,shrunk (- ,end ,size) ,end)))))) (defmacro org-table-save-field (&rest body) "Save current field; execute BODY; restore field. @@ -512,6 +660,66 @@ Field is restored even in case of abnormal exit." (org-table-goto-column ,column) (set-marker ,line nil))))) +(defsubst org-table--set-calc-mode (var &optional value) + (if (stringp var) + (setq var (assoc var '(("D" calc-angle-mode deg) + ("R" calc-angle-mode rad) + ("F" calc-prefer-frac t) + ("S" calc-symbolic-mode t))) + value (nth 2 var) var (nth 1 var))) + (if (memq var org-tbl-calc-modes) + (setcar (cdr (memq var org-tbl-calc-modes)) value) + (cons var (cons value org-tbl-calc-modes))) + org-tbl-calc-modes) + + +;;; Predicates + +(defun org-at-TBLFM-p (&optional pos) + "Non-nil when point (or POS) is in #+TBLFM line." + (save-excursion + (goto-char (or pos (point))) + (beginning-of-line) + (and (let ((case-fold-search t)) (looking-at org-TBLFM-regexp)) + (eq (org-element-type (org-element-at-point)) 'table)))) + +(defun org-at-table-p (&optional table-type) + "Non-nil if the cursor is inside an Org table. +If TABLE-TYPE is non-nil, also check for table.el-type tables." + (and (org-match-line (if table-type "[ \t]*[|+]" "[ \t]*|")) + (or (not (derived-mode-p 'org-mode)) + (let ((e (org-element-lineage (org-element-at-point) '(table) t))) + (and e (or table-type + (eq 'org (org-element-property :type e)))))))) + +(defun org-at-table.el-p () + "Non-nil when point is at a table.el table." + (and (org-match-line "[ \t]*[|+]") + (let ((element (org-element-at-point))) + (and (eq (org-element-type element) 'table) + (eq (org-element-property :type element) 'table.el))))) + +(defun org-at-table-hline-p () + "Non-nil when point is inside a hline in a table. +Assume point is already in a table." + (org-match-line org-table-hline-regexp)) + +(defun org-table-check-inside-data-field (&optional noerror assume-table) + "Non-nil when point is inside a table data field. +Raise an error otherwise, unless NOERROR is non-nil. In that +case, return nil if point is not inside a data field. When +optional argument ASSUME-TABLE is non-nil, assume point is within +a table." + (cond ((and (or assume-table (org-at-table-p)) + (not (save-excursion (skip-chars-backward " \t") (bolp))) + (not (org-at-table-hline-p)) + (not (looking-at-p "[ \t]*$")))) + (noerror nil) + (t (user-error "Not in table data field")))) + + +;;; Create, Import, and Convert Tables + ;;;###autoload (defun org-table-create-with-table.el () "Use the table.el package to insert a new table. @@ -520,13 +728,13 @@ and table.el tables." (interactive) (require 'table) (cond - ((org-at-table.el-p) - (if (y-or-n-p "Convert table to Org table? ") - (org-table-convert))) - ((org-at-table-p) - (when (y-or-n-p "Convert table to table.el table? ") - (org-table-align) - (org-table-convert))) + ((and (org-at-table.el-p) + (y-or-n-p "Convert table to Org table? ")) + (org-table-convert)) + ((and (org-at-table-p) + (y-or-n-p "Convert table to table.el table? ")) + (org-table-align) + (org-table-convert)) (t (call-interactively 'table-insert)))) ;;;###autoload @@ -567,12 +775,11 @@ SIZE is a string Columns x Rows like for example \"3x2\"." ;; (mapcar (lambda (x) (insert line)) (make-list rows t)) (dotimes (_ rows) (insert line)) (goto-char pos) - (if (> rows 1) - ;; Insert a hline after the first row. - (progn - (end-of-line 1) - (insert "\n|-") - (goto-char pos))) + (when (> rows 1) + ;; Insert a hline after the first row. + (end-of-line 1) + (insert "\n|-") + (goto-char pos)) (org-table-align))) ;;;###autoload @@ -602,8 +809,8 @@ nil When nil, the command tries to be smart and figure out the (if (> (count-lines beg end) org-table-convert-region-max-lines) (user-error "Region is longer than `org-table-convert-region-max-lines' (%s) lines; not converting" org-table-convert-region-max-lines) - (if (equal separator '(64)) - (setq separator (read-regexp "Regexp for field separator"))) + (when (equal separator '(64)) + (setq separator (read-regexp "Regexp for field separator"))) (goto-char beg) (beginning-of-line 1) (setq beg (point-marker)) @@ -672,264 +879,53 @@ regexp When a regular expression, use it to match the separator." (insert-file-contents file) (org-table-convert-region beg (+ (point) (- (point-max) pm)) separator))) - -;;;###autoload -(defun org-table-export (&optional file format) - "Export table to a file, with configurable format. -Such a file can be imported into usual spreadsheet programs. - -FILE can be the output file name. If not given, it will be taken -from a TABLE_EXPORT_FILE property in the current entry or higher -up in the hierarchy, or the user will be prompted for a file -name. FORMAT can be an export format, of the same kind as it -used when `orgtbl-mode' sends a table in a different format. - -The command suggests a format depending on TABLE_EXPORT_FORMAT, -whether it is set locally or up in the hierarchy, then on the -extension of the given file name, and finally on the variable -`org-table-export-default-format'." +(defun org-table-convert () + "Convert from Org table to table.el and back. +Obviously, this only works within limits. When an Org table is converted +to table.el, all horizontal separator lines get lost, because table.el uses +these as cell boundaries and has no notion of horizontal lines. A table.el +table can be converted to an Org table only if it does not do row or column +spanning. Multiline cells will become multiple cells. Beware, Org mode +does not test if the table can be successfully converted - it blindly +applies a recipe that works for simple tables." (interactive) - (unless (org-at-table-p) (user-error "No table at point")) - (org-table-align) ; Make sure we have everything we need. - (let ((file (or file (org-entry-get (point) "TABLE_EXPORT_FILE" t)))) - (unless file - (setq file (read-file-name "Export table to: ")) - (unless (or (not (file-exists-p file)) - (y-or-n-p (format "Overwrite file %s? " file))) - (user-error "File not written"))) - (when (file-directory-p file) - (user-error "This is a directory path, not a file")) - (when (and (buffer-file-name (buffer-base-buffer)) - (file-equal-p - (file-truename file) - (file-truename (buffer-file-name (buffer-base-buffer))))) - (user-error "Please specify a file name that is different from current")) - (let ((fileext (concat (file-name-extension file) "$")) - (format (or format (org-entry-get (point) "TABLE_EXPORT_FORMAT" t)))) - (unless format - (let* ((formats '("orgtbl-to-tsv" "orgtbl-to-csv" "orgtbl-to-latex" - "orgtbl-to-html" "orgtbl-to-generic" - "orgtbl-to-texinfo" "orgtbl-to-orgtbl" - "orgtbl-to-unicode")) - (deffmt-readable - (replace-regexp-in-string - "\t" "\\t" - (replace-regexp-in-string - "\n" "\\n" - (or (car (delq nil - (mapcar - (lambda (f) - (and (string-match-p fileext f) f)) - formats))) - org-table-export-default-format) - t t) t t))) - (setq format - (org-completing-read - "Format: " formats nil nil deffmt-readable)))) - (if (string-match "\\([^ \t\r\n]+\\)\\( +.*\\)?" format) - (let ((transform (intern (match-string 1 format))) - (params (and (match-end 2) - (read (concat "(" (match-string 2 format) ")")))) - (table (org-table-to-lisp - (buffer-substring-no-properties - (org-table-begin) (org-table-end))))) - (unless (fboundp transform) - (user-error "No such transformation function %s" transform)) - (let (buf) - (with-current-buffer (find-file-noselect file) - (setq buf (current-buffer)) - (erase-buffer) - (fundamental-mode) - (insert (funcall transform table params) "\n") - (save-buffer)) - (kill-buffer buf)) - (message "Export done.")) - (user-error "TABLE_EXPORT_FORMAT invalid"))))) - -(defvar org-table-aligned-begin-marker (make-marker) - "Marker at the beginning of the table last aligned. -Used to check if cursor still is in that table, to minimize realignment.") -(defvar org-table-aligned-end-marker (make-marker) - "Marker at the end of the table last aligned. -Used to check if cursor still is in that table, to minimize realignment.") -(defvar org-table-last-alignment nil - "List of flags for flushright alignment, from the last re-alignment. -This is being used to correctly align a single field after TAB or RET.") -(defvar org-table-last-column-widths nil - "List of max width of fields in each column. -This is being used to correctly align a single field after TAB or RET.") -(defvar-local org-table-formula-debug nil - "Non-nil means debug table formulas. -When nil, simply write \"#ERROR\" in corrupted fields.") -(defvar-local org-table-overlay-coordinates nil - "Overlay coordinates after each align of a table.") - -(defvar org-last-recalc-line nil) -(defvar org-table-do-narrow t) ; for dynamic scoping -(defconst org-narrow-column-arrow "=>" - "Used as display property in narrowed table columns.") + (require 'table) + (if (org-at-table.el-p) + ;; convert to Org table + (let ((beg (copy-marker (org-table-begin t))) + (end (copy-marker (org-table-end t)))) + (table-unrecognize-region beg end) + (goto-char beg) + (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) + (replace-match "")) + (goto-char beg)) + (if (org-at-table-p) + ;; convert to table.el table + (let ((beg (copy-marker (org-table-begin))) + (end (copy-marker (org-table-end)))) + ;; first, get rid of all horizontal lines + (goto-char beg) + (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) + (replace-match "")) + ;; insert a hline before first + (goto-char beg) + (org-table-insert-hline 'above) + (beginning-of-line -1) + ;; insert a hline after each line + (while (progn (beginning-of-line 3) (< (point) end)) + (org-table-insert-hline)) + (goto-char beg) + (setq end (move-marker end (org-table-end))) + ;; replace "+" at beginning and ending of hlines + (while (re-search-forward "^\\([ \t]*\\)|-" end t) + (replace-match "\\1+-")) + (goto-char beg) + (while (re-search-forward "-|[ \t]*$" end t) + (replace-match "-+")) + (goto-char beg))))) -;;;###autoload -(defun org-table-align () - "Align the table at point by aligning all vertical bars." - (interactive) - (let* ((beg (org-table-begin)) - (end (copy-marker (org-table-end)))) - (org-table-save-field - ;; Make sure invisible characters in the table are at the right - ;; place since column widths take them into account. - (font-lock-fontify-region beg end) - (move-marker org-table-aligned-begin-marker beg) - (move-marker org-table-aligned-end-marker end) - (goto-char beg) - (let* ((indent (progn (looking-at "[ \t]*") (match-string 0))) - ;; Table's rows. Separators are replaced by nil. Trailing - ;; spaces are also removed. - (lines (mapcar (lambda (l) - (and (not (string-match-p "\\`[ \t]*|-" l)) - (let ((l (org-trim l))) - (remove-text-properties - 0 (length l) '(display t org-cwidth t) l) - l))) - (org-split-string (buffer-substring beg end) "\n"))) - ;; Get the data fields by splitting the lines. - (fields (mapcar (lambda (l) (org-split-string l " *| *")) - (remq nil lines))) - ;; Compute number of fields in the longest line. If the - ;; table contains no field, create a default table. - (maxfields (if fields (apply #'max (mapcar #'length fields)) - (kill-region beg end) - (org-table-create org-table-default-size) - (user-error "Empty table - created default table"))) - ;; A list of empty strings to fill any short rows on output. - (emptycells (make-list maxfields "")) - lengths typenums) - ;; Check for special formatting. - (dotimes (i maxfields) - (let ((column (mapcar (lambda (x) (or (nth i x) "")) fields)) - fmax falign) - ;; Look for an explicit width or alignment. - (when (save-excursion - (or (re-search-forward "| *<[lrc][0-9]*> *\\(|\\|$\\)" end t) - (and org-table-do-narrow - (re-search-forward - "| *<[lrc]?[0-9]+> *\\(|\\|$\\)" end t)))) - (catch :exit - (dolist (cell column) - (when (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)?>\\'" cell) - (when (match-end 1) (setq falign (match-string 1 cell))) - (when (and org-table-do-narrow (match-end 2)) - (setq fmax (string-to-number (match-string 2 cell)))) - (when (or falign fmax) (throw :exit nil))))) - ;; Find fields that are wider than FMAX, and shorten them. - (when fmax - (dolist (x column) - (when (> (string-width x) fmax) - (org-add-props x nil - 'help-echo - (concat - "Clipped table field, use `\\[org-table-edit-field]' to \ -edit. Full value is:\n" - (substring-no-properties x))) - (let ((l (length x)) - (f1 (min fmax - (or (string-match org-bracket-link-regexp x) - fmax))) - (f2 1)) - (unless (> f1 1) - (user-error - "Cannot narrow field starting with wide link \"%s\"" - (match-string 0 x))) - (if (= (org-string-width x) l) (setq f2 f1) - (setq f2 1) - (while (< (org-string-width (substring x 0 f2)) f1) - (cl-incf f2))) - (add-text-properties f2 l (list 'org-cwidth t) x) - (add-text-properties - (if (>= (string-width (substring x (1- f2) f2)) 2) (1- f2) - (- f2 2)) - f2 - (list 'display org-narrow-column-arrow) - x)))))) - ;; Get the maximum width for each column - (push (or fmax (apply #'max 1 (mapcar #'org-string-width column))) - lengths) - ;; Get the fraction of numbers among non-empty cells to - ;; decide about alignment of the column. - (if falign (push (equal (downcase falign) "r") typenums) - (let ((cnt 0) - (frac 0.0)) - (dolist (x column) - (unless (equal x "") - (setq frac - (/ (+ (* frac cnt) - (if (string-match-p org-table-number-regexp x) - 1 - 0)) - (cl-incf cnt))))) - (push (>= frac org-table-number-fraction) typenums))))) - (setq lengths (nreverse lengths)) - (setq typenums (nreverse typenums)) - ;; Store alignment of this table, for later editing of single - ;; fields. - (setq org-table-last-alignment typenums) - (setq org-table-last-column-widths lengths) - ;; With invisible characters, `format' does not get the field - ;; width right So we need to make these fields wide by hand. - ;; Invisible characters may be introduced by fontified links, - ;; emphasis, macros or sub/superscripts. - (when (or (text-property-any beg end 'invisible 'org-link) - (text-property-any beg end 'invisible t)) - (dotimes (i maxfields) - (let ((len (nth i lengths))) - (dotimes (j (length fields)) - (let* ((c (nthcdr i (nth j fields))) - (cell (car c))) - (when (and - (stringp cell) - (let ((l (length cell))) - (or (text-property-any 0 l 'invisible 'org-link cell) - (text-property-any beg end 'invisible t))) - (< (org-string-width cell) len)) - (let ((s (make-string (- len (org-string-width cell)) ?\s))) - (setcar c (if (nth i typenums) (concat s cell) - (concat cell s)))))))))) - - ;; Compute the formats needed for output of the table. - (let ((hfmt (concat indent "|")) - (rfmt (concat indent "|")) - (rfmt1 " %%%s%ds |") - (hfmt1 "-%s-+")) - (dolist (l lengths (setq hfmt (concat (substring hfmt 0 -1) "|"))) - (let ((ty (if (pop typenums) "" "-"))) ; Flush numbers right. - (setq rfmt (concat rfmt (format rfmt1 ty l))) - (setq hfmt (concat hfmt (format hfmt1 (make-string l ?-)))))) - ;; Replace modified lines only. Check not only contents, but - ;; also columns' width. - (dolist (l lines) - (let ((line - (if l (apply #'format rfmt (append (pop fields) emptycells)) - hfmt)) - (previous (buffer-substring (point) (line-end-position)))) - (if (and (equal previous line) - (let ((a 0) - (b 0)) - (while (and (progn - (setq a (next-single-property-change - a 'org-cwidth previous)) - (setq b (next-single-property-change - b 'org-cwidth line))) - (eq a b))) - (eq a b))) - (forward-line) - (insert line "\n") - (delete-region (point) (line-beginning-position 2)))))) - (when (and orgtbl-mode (not (derived-mode-p 'org-mode))) - (goto-char org-table-aligned-begin-marker) - (while (org-hide-wide-columns org-table-aligned-end-marker))) - (set-marker end nil) - (when org-table-overlay-coordinates (org-table-overlay-coordinates)) - (setq org-table-may-need-update nil))))) + +;;; Navigation and Structure Editing ;;;###autoload (defun org-table-begin (&optional table-type) @@ -967,58 +963,15 @@ a table." (if (bolp) (point) (line-end-position)))))) ;;;###autoload -(defun org-table-justify-field-maybe (&optional new) - "Justify the current field, text to left, number to right. -Optional argument NEW may specify text to replace the current field content." - (cond - ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway - ((org-at-table-hline-p)) - ((and (not new) - (or (not (eq (marker-buffer org-table-aligned-begin-marker) - (current-buffer))) - (< (point) org-table-aligned-begin-marker) - (>= (point) org-table-aligned-end-marker))) - ;; This is not the same table, force a full re-align. - (setq org-table-may-need-update t)) - (t - ;; Realign the current field, based on previous full realign. - (let ((pos (point)) - (col (org-table-current-column))) - (when (> col 0) - (skip-chars-backward "^|") - (if (not (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)")) - (setq org-table-may-need-update t) - (let* ((numbers? (nth (1- col) org-table-last-alignment)) - (cell (match-string 0)) - (field (match-string 1)) - (len (max 1 (- (org-string-width cell) 3))) - (properly-closed? (/= (match-beginning 2) (match-end 2))) - (fmt (format (if numbers? " %%%ds %s" " %%-%ds %s") - len - (if properly-closed? "|" - (setq org-table-may-need-update t) - ""))) - (new-cell - (cond ((not new) (format fmt field)) - ((<= (org-string-width new) len) (format fmt new)) - (t - (setq org-table-may-need-update t) - (format " %s |" new))))) - (unless (equal new-cell cell) - (let (org-table-may-need-update) - (replace-match new-cell t t))) - (goto-char pos)))))))) - -;;;###autoload (defun org-table-next-field () "Go to the next field in the current table, creating new lines as needed. Before doing so, re-align the table if necessary." (interactive) (org-table-maybe-eval-formula) (org-table-maybe-recalculate-line) - (if (and org-table-automatic-realign - org-table-may-need-update) - (org-table-align)) + (when (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) (let ((end (org-table-end))) (if (org-at-table-hline-p) (end-of-line 1)) @@ -1078,7 +1031,7 @@ With numeric argument N, move N-1 fields backward first." (user-error "No more table fields before the current") (goto-char (match-end 0)) (and (looking-at " ") (forward-char 1))) - (if (>= (point) pos) (org-table-beginning-of-field 2)))) + (when (>= (point) pos) (org-table-beginning-of-field 2)))) (defun org-table-end-of-field (&optional n) "Move to the end of the current table field. @@ -1092,9 +1045,9 @@ With numeric argument N, move N-1 fields forward first." (when (re-search-forward "|" (point-at-eol 1) t) (backward-char 1) (skip-chars-backward " ") - (if (and (equal (char-before (point)) ?|) (looking-at " ")) - (forward-char 1))) - (if (<= (point) pos) (org-table-end-of-field 2)))) + (when (and (equal (char-before (point)) ?|) (equal (char-after (point)) ?\s)) + (forward-char 1))) + (when (<= (point) pos) (org-table-end-of-field 2)))) ;;;###autoload (defun org-table-next-row () @@ -1108,6 +1061,7 @@ Before doing so, re-align the table if necessary." (org-table-align)) (let ((col (org-table-current-column))) (beginning-of-line 2) + (unless (bolp) (insert "\n")) ;missing newline at eob (when (or (not (org-at-table-p)) (org-at-table-hline-p)) (beginning-of-line 0) @@ -1116,106 +1070,6 @@ Before doing so, re-align the table if necessary." (skip-chars-backward "^|\n\r") (when (looking-at " ") (forward-char)))) -;;;###autoload -(defun org-table-copy-down (n) - "Copy the value of the current field one row below. - -If the field at the cursor is empty, copy the content of the -nearest non-empty field above. With argument N, use the Nth -non-empty field. - -If the current field is not empty, it is copied down to the next -row, and the cursor is moved with it. Therefore, repeating this -command causes the column to be filled row-by-row. - -If the variable `org-table-copy-increment' is non-nil and the -field is an integer or a timestamp, it will be incremented while -copying. By default, increment by the difference between the -value in the current field and the one in the field above. To -increment using a fixed integer, set `org-table-copy-increment' -to a number. In the case of a timestamp, increment by days." - (interactive "p") - (let* ((colpos (org-table-current-column)) - (col (current-column)) - (field (save-excursion (org-table-get-field))) - (field-up (or (save-excursion - (org-table-get (1- (org-table-current-line)) - (org-table-current-column))) "")) - (non-empty (string-match "[^ \t]" field)) - (non-empty-up (string-match "[^ \t]" field-up)) - (beg (org-table-begin)) - (orig-n n) - txt txt-up inc) - (org-table-check-inside-data-field) - (if (not non-empty) - (save-excursion - (setq txt - (catch 'exit - (while (progn (beginning-of-line 1) - (re-search-backward org-table-dataline-regexp - beg t)) - (org-table-goto-column colpos t) - (if (and (looking-at - "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") - (<= (setq n (1- n)) 0)) - (throw 'exit (match-string 1)))))) - (setq field-up - (catch 'exit - (while (progn (beginning-of-line 1) - (re-search-backward org-table-dataline-regexp - beg t)) - (org-table-goto-column colpos t) - (if (and (looking-at - "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") - (<= (setq n (1- n)) 0)) - (throw 'exit (match-string 1)))))) - (setq non-empty-up (and field-up (string-match "[^ \t]" field-up)))) - ;; Above field was not empty, go down to the next row - (setq txt (org-trim field)) - (org-table-next-row) - (org-table-blank-field)) - (if non-empty-up (setq txt-up (org-trim field-up))) - (setq inc (cond - ((numberp org-table-copy-increment) org-table-copy-increment) - (txt-up (cond ((and (string-match org-ts-regexp3 txt-up) - (string-match org-ts-regexp3 txt)) - (- (org-time-string-to-absolute txt) - (org-time-string-to-absolute txt-up))) - ((string-match org-ts-regexp3 txt) 1) - ((string-match "\\([-+]\\)?[0-9]*\\(?:\\.[0-9]+\\)?" txt-up) - (- (string-to-number txt) - (string-to-number (match-string 0 txt-up)))) - (t 1))) - (t 1))) - (if (not txt) - (user-error "No non-empty field found") - (if (and org-table-copy-increment - (not (equal orig-n 0)) - (string-match-p "^[-+^/*0-9eE.]+$" txt) - (< (string-to-number txt) 100000000)) - (setq txt (calc-eval (concat txt "+" (number-to-string inc))))) - (insert txt) - (org-move-to-column col) - (if (and org-table-copy-increment (org-at-timestamp-p 'lax)) - (org-timestamp-up-day inc) - (org-table-maybe-recalculate-line)) - (org-table-align) - (org-move-to-column col)))) - -(defun org-table-check-inside-data-field (&optional noerror) - "Is point inside a table data field? -I.e. not on a hline or before the first or after the last column? -This actually throws an error, so it aborts the current command." - (cond ((and (org-at-table-p) - (not (save-excursion (skip-chars-backward " \t") (bolp))) - (not (org-at-table-hline-p)) - (not (looking-at "[ \t]*$")))) - (noerror nil) - (t (user-error "Not in table data field")))) - -(defvar org-table-clip nil - "Clipboard for table regions.") - (defun org-table-get (line column) "Get the field in table line LINE, column COLUMN. If LINE is larger than the number of data lines in the table, the function @@ -1248,6 +1102,30 @@ When ALIGN is set, also realign the table." (< (point-at-eol) pos)))) cnt)) +(defun org-table-current-column () + "Return current column number." + (interactive) + (save-excursion + (let ((pos (point))) + (beginning-of-line) + (if (not (search-forward "|" pos t)) 0 + (let ((column 1) + (separator (if (org-at-table-hline-p) "[+|]" "|"))) + (while (re-search-forward separator pos t) (cl-incf column)) + column))))) + +(defun org-table-current-dline () + "Find out what table data line we are in. +Only data lines count for this." + (save-excursion + (let ((c 0) + (pos (line-beginning-position))) + (goto-char (org-table-begin)) + (while (<= (point) pos) + (when (looking-at org-table-dataline-regexp) (cl-incf c)) + (forward-line)) + c))) + (defun org-table-goto-line (N) "Go to the Nth data line in the current table. Return t when the line exists, nil if it does not exist." @@ -1289,7 +1167,8 @@ value." (let* ((pos (match-beginning 0)) (val (buffer-substring pos (match-end 0)))) (when replace - (replace-match (if (equal replace "") " " replace) t t)) + (org-table-with-shrunk-field + (replace-match (if (equal replace "") " " replace) t t))) (goto-char (min (line-end-position) (1+ pos))) val))) @@ -1341,26 +1220,36 @@ value." (car eqn) "=" (cdr eqn)))) ""))))) -(defun org-table-current-column () - "Find out which column we are in." - (interactive) - (save-excursion - (let ((column 0) (pos (point))) - (beginning-of-line) - (while (search-forward "|" pos t) (cl-incf column)) - column))) +(defun org-table-goto-field (ref &optional create-column-p) + "Move point to a specific field in the current table. -(defun org-table-current-dline () - "Find out what table data line we are in. -Only data lines count for this." - (save-excursion - (let ((c 0) - (pos (line-beginning-position))) - (goto-char (org-table-begin)) - (while (<= (point) pos) - (when (looking-at org-table-dataline-regexp) (cl-incf c)) - (forward-line)) - c))) +REF is either the name of a field its absolute reference, as +a string. No column is created unless CREATE-COLUMN-P is +non-nil. If it is a function, it is called with the column +number as its argument as is used as a predicate to know if the +column can be created. + +This function assumes the table is already analyzed (i.e., using +`org-table-analyze')." + (let* ((coordinates + (cond + ((cdr (assoc ref org-table-named-field-locations))) + ((string-match "\\`@\\([1-9][0-9]*\\)\\$\\([1-9][0-9]*\\)\\'" ref) + (list (condition-case nil + (aref org-table-dlines + (string-to-number (match-string 1 ref))) + (error (user-error "Invalid row number in %s" ref))) + (string-to-number (match-string 2 ref)))) + (t (user-error "Unknown field: %s" ref)))) + (line (car coordinates)) + (column (nth 1 coordinates)) + (create-new-column (if (functionp create-column-p) + (funcall create-column-p column) + create-column-p))) + (when coordinates + (goto-char org-table-current-begin-pos) + (forward-line line) + (org-table-goto-column column nil create-new-column)))) ;;;###autoload (defun org-table-goto-column (n &optional on-delim force) @@ -1391,41 +1280,50 @@ However, when FORCE is non-nil, create new columns if necessary." (interactive) (unless (org-at-table-p) (user-error "Not at a table")) (org-table-find-dataline) - (let* ((col (max 1 (org-table-current-column))) - (beg (org-table-begin)) - (end (copy-marker (org-table-end)))) - (org-table-save-field - (goto-char beg) - (while (< (point) end) - (unless (org-at-table-hline-p) - (org-table-goto-column col t) - (insert "| ")) - (forward-line))) - (set-marker end nil) + (let ((col (max 1 (org-table-current-column))) + (beg (org-table-begin)) + (end (copy-marker (org-table-end))) + (shrunk-columns (org-table--list-shrunk-columns))) + (org-table-expand beg end) + (save-excursion + (goto-char beg) + (while (< (point) end) + (unless (org-at-table-hline-p) + (org-table-goto-column col t) + (unless (search-forward "|" (line-end-position) t 2) + ;; Add missing vertical bar at the end of the row. + (end-of-line) + (insert "|")) + (insert " |")) + (forward-line))) + (org-table-goto-column (1+ col)) (org-table-align) + ;; Shift appropriately stored shrunk column numbers, then hide the + ;; columns again. + (org-table--shrink-columns (mapcar (lambda (c) (if (<= c col) c (1+ c))) + shrunk-columns) + beg end) + (set-marker end nil) + ;; Fix TBLFM formulas, if desirable. (when (or (not org-table-fix-formulas-confirm) (funcall org-table-fix-formulas-confirm "Fix formulas? ")) (org-table-fix-formulas "$" nil (1- col) 1) (org-table-fix-formulas "$LR" nil (1- col) 1)))) (defun org-table-find-dataline () - "Find a data line in the current table, which is needed for column commands." - (if (and (org-at-table-p) - (not (org-at-table-hline-p))) - t - (let ((col (current-column)) - (end (org-table-end))) - (org-move-to-column col) - (while (and (< (point) end) - (or (not (= (current-column) col)) - (org-at-table-hline-p))) - (beginning-of-line 2) - (org-move-to-column col)) - (if (and (org-at-table-p) - (not (org-at-table-hline-p))) - t - (user-error - "Please position cursor in a data line for column operations"))))) + "Find a data line in the current table, which is needed for column commands. +This function assumes point is in a table. Raise an error when +there is no data row below." + (or (not (org-at-table-hline-p)) + (let ((col (current-column)) + (end (org-table-end))) + (forward-line) + (while (and (< (point) end) (org-at-table-hline-p)) + (forward-line)) + (when (>= (point) end) + (user-error "Cannot find data row for column operation")) + (org-move-to-column col) + t))) (defun org-table-line-to-dline (line &optional above) "Turn a buffer line number into a data line number. @@ -1440,7 +1338,7 @@ non-nil, the one above is used." (cond ((or (> (aref org-table-dlines min) line) (< (aref org-table-dlines max) line)) nil) - ((= (aref org-table-dlines max) line) max) + ((= line (aref org-table-dlines max)) max) (t (catch 'exit (while (> (- max min) 1) (let* ((mean (/ (+ max min) 2)) @@ -1448,7 +1346,84 @@ non-nil, the one above is used." (cond ((= v line) (throw 'exit mean)) ((> v line) (setq max mean)) (t (setq min mean))))) - (if above min max)))))) + (cond ((= line (aref org-table-dlines max)) max) + ((= line (aref org-table-dlines min)) min) + (above min) + (t max))))))) + +(defun org-table--swap-cells (row1 col1 row2 col2) + "Swap two cells indicated by the coordinates provided. +ROW1, COL1, ROW2, COL2 are integers indicating the row/column +position of the two cells that will be swapped in the table." + (let ((content1 (org-table-get row1 col1)) + (content2 (org-table-get row2 col2))) + (org-table-put row1 col1 content2) + (org-table-put row2 col2 content1))) + +(defun org-table--move-cell (direction) + "Move the current cell in a cardinal direction. +DIRECTION is a symbol among `up', `down', `left', and `right'. +The contents the current cell are swapped with cell in the +indicated direction. Raise an error if the move cannot be done." + (let ((row-shift (pcase direction (`up -1) (`down 1) (_ 0))) + (column-shift (pcase direction (`left -1) (`right 1) (_ 0)))) + (when (and (= 0 row-shift) (= 0 column-shift)) + (error "Invalid direction: %S" direction)) + ;; Initialize `org-table-current-ncol' and `org-table-dlines'. + (org-table-analyze) + (let* ((row (org-table-current-line)) + (column (org-table-current-column)) + (target-row (+ row row-shift)) + (target-column (+ column column-shift)) + (org-table-current-nrow (1- (length org-table-dlines)))) + (when (or (< target-column 1) + (< target-row 1) + (> target-column org-table-current-ncol) + (> target-row org-table-current-nrow)) + (user-error "Cannot move cell further")) + (org-table--swap-cells row column target-row target-column) + (org-table-goto-line target-row) + (org-table-goto-column target-column)))) + +;;;###autoload +(defun org-table-move-cell-up () + "Move a single cell up in a table. +Swap with anything in target cell." + (interactive) + (unless (org-table-check-inside-data-field) + (error "No table at point")) + (org-table--move-cell 'up) + (org-table-align)) + +;;;###autoload +(defun org-table-move-cell-down () + "Move a single cell down in a table. +Swap with anything in target cell." + (interactive) + (unless (org-table-check-inside-data-field) + (error "No table at point")) + (org-table--move-cell 'down) + (org-table-align)) + +;;;###autoload +(defun org-table-move-cell-left () + "Move a single cell left in a table. +Swap with anything in target cell." + (interactive) + (unless (org-table-check-inside-data-field) + (error "No table at point")) + (org-table--move-cell 'left) + (org-table-align)) + +;;;###autoload +(defun org-table-move-cell-right () + "Move a single cell right in a table. +Swap with anything in target cell." + (interactive) + (unless (org-table-check-inside-data-field) + (error "No table at point")) + (org-table--move-cell 'right) + (org-table-align)) ;;;###autoload (defun org-table-delete-column () @@ -1456,10 +1431,12 @@ non-nil, the one above is used." (interactive) (unless (org-at-table-p) (user-error "Not at a table")) (org-table-find-dataline) - (org-table-check-inside-data-field) - (let ((col (org-table-current-column)) - (beg (org-table-begin)) - (end (copy-marker (org-table-end)))) + (org-table-check-inside-data-field nil t) + (let* ((col (org-table-current-column)) + (beg (org-table-begin)) + (end (copy-marker (org-table-end))) + (shrunk-columns (remq col (org-table--list-shrunk-columns)))) + (org-table-expand beg end) (org-table-save-field (goto-char beg) (while (< (point) end) @@ -1469,9 +1446,15 @@ non-nil, the one above is used." (and (looking-at "|[^|\n]+|") (replace-match "|"))) (forward-line))) - (set-marker end nil) (org-table-goto-column (max 1 (1- col))) (org-table-align) + ;; Shift appropriately stored shrunk column numbers, then hide the + ;; columns again. + (org-table--shrink-columns (mapcar (lambda (c) (if (< c col) c (1- c))) + shrunk-columns) + beg end) + (set-marker end nil) + ;; Fix TBLFM formulas, if desirable. (when (or (not org-table-fix-formulas-confirm) (funcall org-table-fix-formulas-confirm "Fix formulas? ")) (org-table-fix-formulas @@ -1484,6 +1467,7 @@ non-nil, the one above is used." "Move column to the right." (interactive) (org-table-move-column nil)) + ;;;###autoload (defun org-table-move-column-left () "Move column to the left." @@ -1496,7 +1480,7 @@ non-nil, the one above is used." (interactive "P") (unless (org-at-table-p) (user-error "Not at a table")) (org-table-find-dataline) - (org-table-check-inside-data-field) + (org-table-check-inside-data-field nil t) (let* ((col (org-table-current-column)) (col1 (if left (1- col) col)) (colpos (if left (1- col) (1+ col))) @@ -1506,33 +1490,49 @@ non-nil, the one above is used." (user-error "Cannot move column further left")) (when (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) (user-error "Cannot move column further right")) - (org-table-save-field - (goto-char beg) - (while (< (point) end) - (unless (org-at-table-hline-p) - (org-table-goto-column col1 t) - (when (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") - (transpose-regions - (match-beginning 1) (match-end 1) - (match-beginning 2) (match-end 2)))) - (forward-line))) - (set-marker end nil) - (org-table-goto-column colpos) - (org-table-align) - (when (or (not org-table-fix-formulas-confirm) - (funcall org-table-fix-formulas-confirm "Fix formulas? ")) - (org-table-fix-formulas - "$" (list (cons (number-to-string col) (number-to-string colpos)) - (cons (number-to-string colpos) (number-to-string col)))) - (org-table-fix-formulas - "$LR" (list (cons (number-to-string col) (number-to-string colpos)) - (cons (number-to-string colpos) (number-to-string col))))))) + (let ((shrunk-columns (org-table--list-shrunk-columns))) + (org-table-expand beg end) + (org-table-save-field + (goto-char beg) + (while (< (point) end) + (unless (org-at-table-hline-p) + (org-table-goto-column col1 t) + (when (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") + (transpose-regions + (match-beginning 1) (match-end 1) + (match-beginning 2) (match-end 2)))) + (forward-line))) + (org-table-goto-column colpos) + (org-table-align) + ;; Shift appropriately stored shrunk column numbers, then shrink + ;; the columns again. + (org-table--shrink-columns + (mapcar (lambda (c) + (cond ((and (= col c) left) (1- c)) + ((= col c) (1+ c)) + ((and (= col (1+ c)) left) (1+ c)) + ((and (= col (1- c)) (not left) (1- c))) + (t c))) + shrunk-columns) + beg end) + (set-marker end nil) + ;; Fix TBLFM formulas, if desirable. + (when (or (not org-table-fix-formulas-confirm) + (funcall org-table-fix-formulas-confirm "Fix formulas? ")) + (org-table-fix-formulas + "$" (list (cons (number-to-string col) (number-to-string colpos)) + (cons (number-to-string colpos) (number-to-string col)))) + (org-table-fix-formulas + "$LR" (list + (cons (number-to-string col) (number-to-string colpos)) + (cons (number-to-string colpos) (number-to-string col)))))))) ;;;###autoload (defun org-table-move-row-down () "Move table row down." (interactive) (org-table-move-row nil)) + ;;;###autoload (defun org-table-move-row-up () "Move table row up." @@ -1557,24 +1557,25 @@ non-nil, the one above is used." (when (or (and (not up) (eobp)) (not (org-at-table-p))) (goto-char pos) (user-error "Cannot move row further")) - (setq hline2p (looking-at org-table-hline-regexp)) - (goto-char pos) - (let ((row (delete-and-extract-region (line-beginning-position) - (line-beginning-position 2)))) - (beginning-of-line tonew) - (unless (bolp) (insert "\n")) ;at eob without a newline - (insert row) - (unless (bolp) (insert "\n")) ;missing final newline in ROW - (beginning-of-line 0) - (org-move-to-column col) - (unless (or hline1p hline2p - (not (or (not org-table-fix-formulas-confirm) - (funcall org-table-fix-formulas-confirm - "Fix formulas? ")))) - (org-table-fix-formulas - "@" (list - (cons (number-to-string dline1) (number-to-string dline2)) - (cons (number-to-string dline2) (number-to-string dline1)))))))) + (org-table-with-shrunk-columns + (setq hline2p (looking-at org-table-hline-regexp)) + (goto-char pos) + (let ((row (delete-and-extract-region (line-beginning-position) + (line-beginning-position 2)))) + (beginning-of-line tonew) + (unless (bolp) (insert "\n")) ;at eob without a newline + (insert row) + (unless (bolp) (insert "\n")) ;missing final newline in ROW + (beginning-of-line 0) + (org-move-to-column col) + (unless (or hline1p hline2p + (not (or (not org-table-fix-formulas-confirm) + (funcall org-table-fix-formulas-confirm + "Fix formulas? ")))) + (org-table-fix-formulas + "@" (list + (cons (number-to-string dline1) (number-to-string dline2)) + (cons (number-to-string dline2) (number-to-string dline1))))))))) ;;;###autoload (defun org-table-insert-row (&optional arg) @@ -1582,47 +1583,48 @@ non-nil, the one above is used." With prefix ARG, insert below the current line." (interactive "P") (unless (org-at-table-p) (user-error "Not at a table")) - (let* ((line (buffer-substring (line-beginning-position) (line-end-position))) - (new (org-table-clean-line line))) - ;; Fix the first field if necessary - (if (string-match "^[ \t]*| *[#$] *|" line) - (setq new (replace-match (match-string 0 line) t t new))) - (beginning-of-line (if arg 2 1)) - ;; Buffer may not end of a newline character, so ensure - ;; (beginning-of-line 2) moves point to a new line. - (unless (bolp) (insert "\n")) - (let (org-table-may-need-update) (insert-before-markers new "\n")) - (beginning-of-line 0) - (re-search-forward "| ?" (line-end-position) t) - (when (or org-table-may-need-update org-table-overlay-coordinates) - (org-table-align)) - (when (or (not org-table-fix-formulas-confirm) - (funcall org-table-fix-formulas-confirm "Fix formulas? ")) - (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1)))) + (org-table-with-shrunk-columns + (let* ((line (buffer-substring (line-beginning-position) (line-end-position))) + (new (org-table-clean-line line))) + ;; Fix the first field if necessary + (when (string-match "^[ \t]*| *[#*$] *|" line) + (setq new (replace-match (match-string 0 line) t t new))) + (beginning-of-line (if arg 2 1)) + ;; Buffer may not end of a newline character, so ensure + ;; (beginning-of-line 2) moves point to a new line. + (unless (bolp) (insert "\n")) + (let (org-table-may-need-update) (insert-before-markers new "\n")) + (beginning-of-line 0) + (re-search-forward "| ?" (line-end-position) t) + (when (or org-table-may-need-update org-table-overlay-coordinates) + (org-table-align)) + (when (or (not org-table-fix-formulas-confirm) + (funcall org-table-fix-formulas-confirm "Fix formulas? ")) + (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1))))) ;;;###autoload (defun org-table-insert-hline (&optional above) "Insert a horizontal-line below the current line into the table. With prefix ABOVE, insert above the current line." (interactive "P") - (if (not (org-at-table-p)) - (user-error "Not at a table")) - (when (eobp) (insert "\n") (backward-char 1)) - (if (not (string-match-p "|[ \t]*$" (org-current-line-string))) - (org-table-align)) - (let ((line (org-table-clean-line - (buffer-substring (point-at-bol) (point-at-eol)))) - (col (current-column))) - (while (string-match "|\\( +\\)|" line) - (setq line (replace-match - (concat "+" (make-string (- (match-end 1) (match-beginning 1)) - ?-) "|") t t line))) - (and (string-match "\\+" line) (setq line (replace-match "|" t t line))) - (beginning-of-line (if above 1 2)) - (insert line "\n") - (beginning-of-line (if above 1 -1)) - (org-move-to-column col) - (and org-table-overlay-coordinates (org-table-align)))) + (unless (org-at-table-p) (user-error "Not at a table")) + (when (eobp) (save-excursion (insert "\n"))) + (unless (string-match-p "|[ \t]*$" (org-current-line-string)) + (org-table-align)) + (org-table-with-shrunk-columns + (let ((line (org-table-clean-line + (buffer-substring (point-at-bol) (point-at-eol)))) + (col (current-column))) + (while (string-match "|\\( +\\)|" line) + (setq line (replace-match + (concat "+" (make-string (- (match-end 1) (match-beginning 1)) + ?-) "|") t t line))) + (and (string-match "\\+" line) (setq line (replace-match "|" t t line))) + (beginning-of-line (if above 1 2)) + (insert line "\n") + (beginning-of-line (if above 1 -1)) + (org-move-to-column col) + (when org-table-overlay-coordinates (org-table-align))))) ;;;###autoload (defun org-table-hline-and-move (&optional same-column) @@ -1655,142 +1657,19 @@ In particular, this does handle wide and invisible characters." (defun org-table-kill-row () "Delete the current row or horizontal line from the table." (interactive) - (if (not (org-at-table-p)) - (user-error "Not at a table")) + (unless (org-at-table-p) (user-error "Not at a table")) (let ((col (current-column)) (dline (and (not (org-match-line org-table-hline-regexp)) (org-table-current-dline)))) - (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) - (if (not (org-at-table-p)) (beginning-of-line 0)) - (org-move-to-column col) - (when (and dline - (or (not org-table-fix-formulas-confirm) - (funcall org-table-fix-formulas-confirm "Fix formulas? "))) - (org-table-fix-formulas "@" (list (cons (number-to-string dline) "INVALID")) - dline -1 dline)))) - -;;;###autoload -(defun org-table-sort-lines - (&optional with-case sorting-type getkey-func compare-func interactive?) - "Sort table lines according to the column at point. - -The position of point indicates the column to be used for -sorting, and the range of lines is the range between the nearest -horizontal separator lines, or the entire table of no such lines -exist. If point is before the first column, you will be prompted -for the sorting column. If there is an active region, the mark -specifies the first line and the sorting column, while point -should be in the last line to be included into the sorting. - -The command then prompts for the sorting type which can be -alphabetically, numerically, or by time (as given in a time stamp -in the field, or as a HH:MM value). Sorting in reverse order is -also possible. - -With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive. - -If SORTING-TYPE is specified when this function is called from a Lisp -program, no prompting will take place. SORTING-TYPE must be a character, -any of (?a ?A ?n ?N ?t ?T ?f ?F) where the capital letters indicate that -sorting should be done in reverse order. - -If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies -a function to be called to extract the key. It must return a value -that is compatible with COMPARE-FUNC, the function used to compare -entries. - -A non-nil value for INTERACTIVE? is used to signal that this -function is being called interactively." - (interactive (list current-prefix-arg nil nil nil t)) - (when (org-region-active-p) (goto-char (region-beginning))) - ;; Point must be either within a field or before a data line. - (save-excursion - (skip-chars-backward " \t") - (when (bolp) (search-forward "|" (line-end-position) t)) - (org-table-check-inside-data-field)) - ;; Set appropriate case sensitivity and column used for sorting. - (let ((column (let ((c (org-table-current-column))) - (cond ((> c 0) c) - (interactive? - (read-number "Use column N for sorting: ")) - (t 1)))) - (sorting-type - (or sorting-type - (read-char-exclusive "Sort Table: [a]lphabetic, [n]umeric, \ -\[t]ime, [f]unc. A/N/T/F means reversed: ")))) - (save-restriction - ;; Narrow buffer to appropriate sorting area. - (if (org-region-active-p) - (progn (goto-char (region-beginning)) - (narrow-to-region - (point) - (save-excursion (goto-char (region-end)) - (line-beginning-position 2)))) - (let ((start (org-table-begin)) - (end (org-table-end))) - (narrow-to-region - (save-excursion - (if (re-search-backward org-table-hline-regexp start t) - (line-beginning-position 2) - start)) - (if (save-excursion (re-search-forward org-table-hline-regexp end t)) - (match-beginning 0) - end)))) - ;; Determine arguments for `sort-subr'. Also record original - ;; position. `org-table-save-field' cannot help here since - ;; sorting is too much destructive. - (let* ((sort-fold-case (not with-case)) - (coordinates - (cons (count-lines (point-min) (line-beginning-position)) - (current-column))) - (extract-key-from-field - ;; Function to be called on the contents of the field - ;; used for sorting in the current row. - (cl-case sorting-type - ((?n ?N) #'string-to-number) - ((?a ?A) #'org-sort-remove-invisible) - ((?t ?T) - (lambda (f) - (cond ((string-match org-ts-regexp-both f) - (float-time - (org-time-string-to-time (match-string 0 f)))) - ((org-duration-p f) (org-duration-to-minutes f)) - ((string-match "\\<[0-9]+:[0-9]\\{2\\}\\>" f) - (org-duration-to-minutes (match-string 0 f))) - (t 0)))) - ((?f ?F) - (or getkey-func - (and interactive? - (org-read-function "Function for extracting keys: ")) - (error "Missing key extractor to sort rows"))) - (t (user-error "Invalid sorting type `%c'" sorting-type)))) - (predicate - (cl-case sorting-type - ((?n ?N ?t ?T) #'<) - ((?a ?A) #'string<) - ((?f ?F) - (or compare-func - (and interactive? - (org-read-function - (concat "Function for comparing keys " - "(empty for default `sort-subr' predicate): ") - 'allow-empty))))))) - (goto-char (point-min)) - (sort-subr (memq sorting-type '(?A ?N ?T ?F)) - (lambda () - (forward-line) - (while (and (not (eobp)) - (not (looking-at org-table-dataline-regexp))) - (forward-line))) - #'end-of-line - (lambda () - (funcall extract-key-from-field - (org-trim (org-table-get-field column)))) - nil - predicate) - ;; Move back to initial field. - (forward-line (car coordinates)) - (move-to-column (cdr coordinates)))))) + (org-table-with-shrunk-columns + (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) + (if (not (org-at-table-p)) (beginning-of-line 0)) + (org-move-to-column col) + (when (and dline + (or (not org-table-fix-formulas-confirm) + (funcall org-table-fix-formulas-confirm "Fix formulas? "))) + (org-table-fix-formulas + "@" (list (cons (number-to-string dline) "INVALID")) dline -1 dline))))) ;;;###autoload (defun org-table-cut-region (beg end) @@ -1801,11 +1680,177 @@ If there is no active region, use just the field at point." (if (org-region-active-p) (region-end) (point)))) (org-table-copy-region beg end 'cut)) +(defun org-table--increment-field (field previous) + "Increment string FIELD according to PREVIOUS field. + +Increment FIELD only if it is a string representing a number, per +Emacs Lisp syntax, a timestamp, or is either prefixed or suffixed +with a number. In any other case, return FIELD as-is. + +If PREVIOUS has the same structure as FIELD, e.g., +a number-prefixed string with the same pattern, the increment +step is the difference between numbers (or timestamps, measured +in days) in PREVIOUS and FIELD. Otherwise, it uses +`org-table-copy-increment', if the variable contains a number, or +default to 1. + +The function assumes `org-table-copy-increment' is non-nil." + (let* ((default-step (if (numberp org-table-copy-increment) + org-table-copy-increment + 1)) + (number-regexp ;Lisp read syntax for numbers + (rx (and string-start + (opt (any "+-")) + (or (and (one-or-more digit) (opt ".")) + (and (zero-or-more digit) "." (one-or-more digit))) + (opt (any "eE") (opt (opt (any "+-")) (one-or-more digit))) + string-end))) + (number-prefix-regexp (rx (and string-start (one-or-more digit)))) + (number-suffix-regexp (rx (and (one-or-more digit) string-end))) + (analyze + (lambda (field) + ;; Analyse string FIELD and return information related to + ;; increment or nil. When non-nil, return value has the + ;; following scheme: (TYPE VALUE PATTERN) where + ;; - TYPE is a symbol among `number', `prefix', `suffix' + ;; and `timestamp', + ;; - VALUE is a timestamp if TYPE is `timestamp', or + ;; a number otherwise, + ;; - PATTERN is the field without its prefix, or suffix if + ;; TYPE is either `prefix' or `suffix' , or nil + ;; otherwise. + (cond ((not (org-string-nw-p field)) nil) + ((string-match-p number-regexp field) + (list 'number + (string-to-number field) + nil)) + ((string-match number-prefix-regexp field) + (list 'prefix + (string-to-number (match-string 0 field)) + (substring field (match-end 0)))) + ((string-match number-suffix-regexp field) + (list 'suffix + (string-to-number (match-string 0 field)) + (substring field 0 (match-beginning 0)))) + ((string-match-p org-ts-regexp3 field) + (list 'timestamp field nil)) + (t nil)))) + (next-number-string + (lambda (n1 &optional n2) + ;; Increment number N1 and return it as a string. If N2 + ;; is also a number, deduce increment step from the + ;; difference between N1 and N2. Otherwise, increment + ;; step is `default-step'. + (number-to-string (if n2 (+ n1 (- n1 n2)) (+ n1 default-step))))) + (shift-timestamp + (lambda (t1 &optional t2) + ;; Increment timestamp T1 and return it. If T2 is also + ;; a timestamp, deduce increment step from the difference, + ;; in days, between T1 and T2. Otherwise, increment by + ;; `default-step' days. + (with-temp-buffer + (insert t1) + (org-timestamp-up-day (if (not t2) default-step + (- (org-time-string-to-absolute t1) + (org-time-string-to-absolute t2)))) + (buffer-string))))) + ;; Check if both PREVIOUS and FIELD have the same type. Also, if + ;; the case of prefixed or suffixed numbers, make sure their + ;; pattern, i.e., the part of the string without the prefix or the + ;; suffix, is the same. + (pcase (cons (funcall analyze field) (funcall analyze previous)) + (`((number ,n1 ,_) . (number ,n2 ,_)) + (funcall next-number-string n1 n2)) + (`((number ,n ,_) . ,_) + (funcall next-number-string n)) + (`((prefix ,n1 ,p1) . (prefix ,n2 ,p2)) + (concat (funcall next-number-string n1 (and (equal p1 p2) n2)) p1)) + (`((prefix ,n ,p) . ,_) + (concat (funcall next-number-string n) p)) + (`((suffix ,n1 ,p1) . (suffix ,n2 ,p2)) + (concat p1 (funcall next-number-string n1 (and (equal p1 p2) n2)))) + (`((suffix ,n ,p) . ,_) + (concat p (funcall next-number-string n))) + (`((timestamp ,t1 ,_) . (timestamp ,t2 ,_)) + (funcall shift-timestamp t1 t2)) + (`((timestamp ,t1 ,_) . ,_) + (funcall shift-timestamp t1)) + (_ field)))) + +;;;###autoload +(defun org-table-copy-down (n) + "Copy the value of the current field one row below. + +If the field at the cursor is empty, copy the content of the +nearest non-empty field above. With argument N, use the Nth +non-empty field. + +If the current field is not empty, it is copied down to the next +row, and the cursor is moved with it. Therefore, repeating this +command causes the column to be filled row-by-row. + +If the variable `org-table-copy-increment' is non-nil and the +field is a number, a timestamp, or is either prefixed or suffixed +with a number, it will be incremented while copying. By default, +increment by the difference between the value in the current +field and the one in the field above, if any. To increment using +a fixed integer, set `org-table-copy-increment' to a number. In +the case of a timestamp, increment by days. + +However, when N is 0, do not increment the field at all." + (interactive "p") + (org-table-check-inside-data-field) + (let* ((beg (org-table-begin)) + (column (org-table-current-column)) + (initial-field (save-excursion + (let ((f (org-string-nw-p (org-table-get-field)))) + (and f (org-trim f))))) + field field-above next-field) + (save-excursion + ;; Get reference field. + (if initial-field (setq field initial-field) + (beginning-of-line) + (setq field + (catch :exit + (while (re-search-backward org-table-dataline-regexp beg t) + (let ((f (org-string-nw-p (org-table-get-field column)))) + (cond ((and (> n 1) f) (cl-decf n)) + (f (throw :exit (org-trim f))) + (t nil)) + (beginning-of-line))) + (user-error "No non-empty field found")))) + ;; Check if increment is appropriate, and how it should be done. + (when (and org-table-copy-increment (/= n 0)) + ;; If increment step is not explicit, get non-empty field just + ;; above the field being incremented to guess it. + (unless (numberp org-table-copy-increment) + (setq field-above + (let ((f (unless (= beg (line-beginning-position)) + (forward-line -1) + (not (org-at-table-hline-p)) + (org-table-get-field column)))) + (and (org-string-nw-p f) + (org-trim f))))) + ;; Compute next field. + (setq next-field (org-table--increment-field field field-above)))) + ;; Since initial field in not empty, we modify row below instead. + ;; Skip alignment since we do it at the end of the process anyway. + (when initial-field + (let ((org-table-may-need-update nil)) (org-table-next-row)) + (org-table-blank-field)) + ;; Insert the new field. NEW-FIELD may be nil if + ;; `org-table-increment' is nil, or N = 0. In that case, copy + ;; FIELD. + (insert (or next-field field)) + (org-table-maybe-recalculate-line) + (org-table-align))) + ;;;###autoload (defun org-table-copy-region (beg end &optional cut) "Copy rectangular region in table to clipboard. -A special clipboard is used which can only be accessed -with `org-table-paste-rectangle'." +A special clipboard is used which can only be accessed with +`org-table-paste-rectangle'. Return the region copied, as a list +of lists of fields." (interactive (list (if (org-region-active-p) (region-beginning) (point)) (if (org-region-active-p) (region-end) (point)) @@ -1816,7 +1861,7 @@ with `org-table-paste-rectangle'." (c01 (org-table-current-column)) region) (goto-char (max beg end)) - (org-table-check-inside-data-field) + (org-table-check-inside-data-field nil t) (let* ((end (copy-marker (line-end-position))) (c02 (org-table-current-column)) (column-start (min c01 c02)) @@ -1834,6 +1879,8 @@ with `org-table-paste-rectangle'." (forward-line)) (set-marker end nil)) (when cut (org-table-align)) + (message (substitute-command-keys "Cells in the region copied, use \ +\\[org-table-paste-rectangle] to paste them in a table.")) (setq org-table-clip (nreverse region)))) ;;;###autoload @@ -1864,160 +1911,26 @@ lines." (forward-line))) (org-table-align))) -;;;###autoload -(defun org-table-convert () - "Convert from `org-mode' table to table.el and back. -Obviously, this only works within limits. When an Org table is converted -to table.el, all horizontal separator lines get lost, because table.el uses -these as cell boundaries and has no notion of horizontal lines. A table.el -table can be converted to an Org table only if it does not do row or column -spanning. Multiline cells will become multiple cells. Beware, Org mode -does not test if the table can be successfully converted - it blindly -applies a recipe that works for simple tables." - (interactive) - (require 'table) - (if (org-at-table.el-p) - ;; convert to Org table - (let ((beg (copy-marker (org-table-begin t))) - (end (copy-marker (org-table-end t)))) - (table-unrecognize-region beg end) - (goto-char beg) - (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) - (replace-match "")) - (goto-char beg)) - (if (org-at-table-p) - ;; convert to table.el table - (let ((beg (copy-marker (org-table-begin))) - (end (copy-marker (org-table-end)))) - ;; first, get rid of all horizontal lines - (goto-char beg) - (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) - (replace-match "")) - ;; insert a hline before first - (goto-char beg) - (org-table-insert-hline 'above) - (beginning-of-line -1) - ;; insert a hline after each line - (while (progn (beginning-of-line 3) (< (point) end)) - (org-table-insert-hline)) - (goto-char beg) - (setq end (move-marker end (org-table-end))) - ;; replace "+" at beginning and ending of hlines - (while (re-search-forward "^\\([ \t]*\\)|-" end t) - (replace-match "\\1+-")) - (goto-char beg) - (while (re-search-forward "-|[ \t]*$" end t) - (replace-match "-+")) - (goto-char beg))))) - -(defun org-table-transpose-table-at-point () - "Transpose Org table at point and eliminate hlines. -So a table like - -| 1 | 2 | 4 | 5 | -|---+---+---+---| -| a | b | c | d | -| e | f | g | h | - -will be transposed as - -| 1 | a | e | -| 2 | b | f | -| 4 | c | g | -| 5 | d | h | - -Note that horizontal lines disappear." - (interactive) - (let* ((table (delete 'hline (org-table-to-lisp))) - (dline_old (org-table-current-line)) - (col_old (org-table-current-column)) - (contents (mapcar (lambda (_) - (let ((tp table)) - (mapcar - (lambda (_) - (prog1 - (pop (car tp)) - (setq tp (cdr tp)))) - table))) - (car table)))) - (goto-char (org-table-begin)) - (re-search-forward "|") - (backward-char) - (delete-region (point) (org-table-end)) - (insert (mapconcat - (lambda(x) - (concat "| " (mapconcat 'identity x " | " ) " |\n" )) - contents "")) - (org-table-goto-line col_old) - (org-table-goto-column dline_old)) - (org-table-align)) - -;;;###autoload -(defun org-table-wrap-region (arg) - "Wrap several fields in a column like a paragraph. -This is useful if you'd like to spread the contents of a field over several -lines, in order to keep the table compact. + +;;; Follow Field minor mode -If there is an active region, and both point and mark are in the same column, -the text in the column is wrapped to minimum width for the given number of -lines. Generally, this makes the table more compact. A prefix ARG may be -used to change the number of desired lines. For example, \ -`C-2 \\[org-table-wrap-region]' -formats the selected text to two lines. If the region was longer than two -lines, the remaining lines remain empty. A negative prefix argument reduces -the current number of lines by that amount. The wrapped text is pasted back -into the table. If you formatted it to more lines than it was before, fields -further down in the table get overwritten - so you might need to make space in -the table first. - -If there is no region, the current field is split at the cursor position and -the text fragment to the right of the cursor is prepended to the field one -line down. - -If there is no region, but you specify a prefix ARG, the current field gets -blank, and the content is appended to the field above." - (interactive "P") - (org-table-check-inside-data-field) - (if (org-region-active-p) - ;; There is a region: fill as a paragraph. - (let ((start (region-beginning))) - (org-table-cut-region (region-beginning) (region-end)) - (when (> (length (car org-table-clip)) 1) - (user-error "Region must be limited to single column")) - (let ((nlines (cond ((not arg) (length org-table-clip)) - ((< arg 1) (+ (length org-table-clip) arg)) - (t arg)))) - (setq org-table-clip - (mapcar #'list - (org-wrap (mapconcat #'car org-table-clip " ") - nil - nlines)))) - (goto-char start) - (org-table-paste-rectangle)) - ;; No region, split the current field at point. - (unless (org-get-alist-option org-M-RET-may-split-line 'table) - (skip-chars-forward "^\r\n|")) - (cond - (arg ; Combine with field above. - (let ((s (org-table-blank-field)) - (col (org-table-current-column))) - (forward-line -1) - (while (org-at-table-hline-p) (forward-line -1)) - (org-table-goto-column col) - (skip-chars-forward "^|") - (skip-chars-backward " ") - (insert " " (org-trim s)) - (org-table-align))) - ((looking-at "\\([^|]+\\)+|") ; Split field. - (let ((s (match-string 1))) - (replace-match " |") - (goto-char (match-beginning 0)) - (org-table-next-row) - (insert (org-trim s) " ") - (org-table-align))) - (t (org-table-next-row))))) - -(defvar org-field-marker nil) +(define-minor-mode org-table-follow-field-mode + "Minor mode to make the table field editor window follow the cursor. +When this mode is active, the field editor window will always show the +current field. The mode exits automatically when the cursor leaves the +table (but see `org-table-exit-follow-field-mode-when-leaving-table')." + nil " TblFollow" nil + (if org-table-follow-field-mode + (add-hook 'post-command-hook 'org-table-follow-fields-with-editor + 'append 'local) + (remove-hook 'post-command-hook 'org-table-follow-fields-with-editor 'local) + (let* ((buf (get-buffer "*Org Table Edit Field*")) + (win (and buf (get-buffer-window buf)))) + (when win (delete-window win)) + (when buf + (with-current-buffer buf + (move-marker org-field-marker nil)) + (kill-buffer buf))))) ;;;###autoload (defun org-table-edit-field (arg) @@ -2037,8 +1950,7 @@ toggle `org-table-follow-field-mode'." (arg (let ((b (save-excursion (skip-chars-backward "^|") (point))) (e (save-excursion (skip-chars-forward "^|\r\n") (point)))) - (remove-text-properties b e '(org-cwidth t invisible t - display t intangible t)) + (remove-text-properties b e '(invisible t intangible t)) (if (and (boundp 'font-lock-mode) font-lock-mode) (font-lock-fontify-block)))) (t @@ -2065,15 +1977,24 @@ toggle `org-table-follow-field-mode'." (setq word-wrap t) (goto-char (setq p (point-max))) (insert (org-trim field)) - (remove-text-properties p (point-max) - '(invisible t org-cwidth t display t - intangible t)) + (remove-text-properties p (point-max) '(invisible t intangible t)) (goto-char p) (setq-local org-finish-function 'org-table-finish-edit-field) (setq-local org-window-configuration cw) (setq-local org-field-marker pos) (message "Edit and finish with C-c C-c"))))) +(defun org-table-follow-fields-with-editor () + (if (and org-table-exit-follow-field-mode-when-leaving-table + (not (org-at-table-p))) + ;; We have left the table, exit the follow mode + (org-table-follow-field-mode -1) + (when (org-table-check-inside-data-field 'noerror) + (let ((win (selected-window))) + (org-table-edit-field nil) + (org-fit-window-to-buffer) + (select-window win))))) + (defun org-table-finish-edit-field () "Finish editing a table data field. Remove all newline characters, insert the result into the table, realign @@ -2097,114 +2018,8 @@ the table and kill the editing buffer." (org-table-align) (message "New field value inserted"))) -(define-minor-mode org-table-follow-field-mode - "Minor mode to make the table field editor window follow the cursor. -When this mode is active, the field editor window will always show the -current field. The mode exits automatically when the cursor leaves the -table (but see `org-table-exit-follow-field-mode-when-leaving-table')." - nil " TblFollow" nil - (if org-table-follow-field-mode - (add-hook 'post-command-hook 'org-table-follow-fields-with-editor - 'append 'local) - (remove-hook 'post-command-hook 'org-table-follow-fields-with-editor 'local) - (let* ((buf (get-buffer "*Org Table Edit Field*")) - (win (and buf (get-buffer-window buf)))) - (when win (delete-window win)) - (when buf - (with-current-buffer buf - (move-marker org-field-marker nil)) - (kill-buffer buf))))) - -(defun org-table-follow-fields-with-editor () - (if (and org-table-exit-follow-field-mode-when-leaving-table - (not (org-at-table-p))) - ;; We have left the table, exit the follow mode - (org-table-follow-field-mode -1) - (when (org-table-check-inside-data-field 'noerror) - (let ((win (selected-window))) - (org-table-edit-field nil) - (org-fit-window-to-buffer) - (select-window win))))) - -(defvar org-timecnt) ; dynamically scoped parameter - -;;;###autoload -(defun org-table-sum (&optional beg end nlast) - "Sum numbers in region of current table column. -The result will be displayed in the echo area, and will be available -as kill to be inserted with \\[yank]. - -If there is an active region, it is interpreted as a rectangle and all -numbers in that rectangle will be summed. If there is no active -region and point is located in a table column, sum all numbers in that -column. - -If at least one number looks like a time HH:MM or HH:MM:SS, all other -numbers are assumed to be times as well (in decimal hours) and the -numbers are added as such. - -If NLAST is a number, only the NLAST fields will actually be summed." - (interactive) - (save-excursion - (let (col (org-timecnt 0) diff h m s org-table-clip) - (cond - ((and beg end)) ; beg and end given explicitly - ((org-region-active-p) - (setq beg (region-beginning) end (region-end))) - (t - (setq col (org-table-current-column)) - (goto-char (org-table-begin)) - (unless (re-search-forward "^[ \t]*|[^-]" nil t) - (user-error "No table data")) - (org-table-goto-column col) - (setq beg (point)) - (goto-char (org-table-end)) - (unless (re-search-backward "^[ \t]*|[^-]" nil t) - (user-error "No table data")) - (org-table-goto-column col) - (setq end (point)))) - (let* ((items (apply 'append (org-table-copy-region beg end))) - (items1 (cond ((not nlast) items) - ((>= nlast (length items)) items) - (t (setq items (reverse items)) - (setcdr (nthcdr (1- nlast) items) nil) - (nreverse items)))) - (numbers (delq nil (mapcar 'org-table-get-number-for-summing - items1))) - (res (apply '+ numbers)) - (sres (if (= org-timecnt 0) - (number-to-string res) - (setq diff (* 3600 res) - h (floor diff 3600) diff (mod diff 3600) - m (floor diff 60) diff (mod diff 60) - s diff) - (format "%.0f:%02.0f:%02.0f" h m s)))) - (kill-new sres) - (when (called-interactively-p 'interactive) - (message "%s" (substitute-command-keys - (format "Sum of %d items: %-20s \ -\(\\[yank] will insert result into buffer)" (length numbers) sres)))) - sres)))) - -(defun org-table-get-number-for-summing (s) - (let (n) - (if (string-match "^ *|? *" s) - (setq s (replace-match "" nil nil s))) - (if (string-match " *|? *$" s) - (setq s (replace-match "" nil nil s))) - (setq n (string-to-number s)) - (cond - ((and (string-match "0" s) - (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) - ((string-match "\\`[ \t]+\\'" s) nil) - ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) - (let ((h (string-to-number (or (match-string 1 s) "0"))) - (m (string-to-number (or (match-string 2 s) "0"))) - (s (string-to-number (or (match-string 4 s) "0")))) - (if (boundp 'org-timecnt) (setq org-timecnt (1+ org-timecnt))) - (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) - ((equal n 0) nil) - (t n)))) + +;;; Formulas (defun org-table-current-field-formula (&optional key noerror) "Return the formula active for the current field. @@ -2253,34 +2068,31 @@ When NAMED is non-nil, look for a named equation." (eq (cond ((and stored equation (string-match-p "^ *=? *$" equation)) stored) - ((stringp equation) - equation) - (t (org-table-formula-from-user - (read-string - (org-table-formula-to-user - (format "%s formula %s=" - (if named "Field" "Column") - scol)) - (if stored (org-table-formula-to-user stored) "") - 'org-table-formula-history - ))))) + ((stringp equation) equation) + (t + (org-table-formula-from-user + (read-string + (org-table-formula-to-user + (format "%s formula %s=" (if named "Field" "Column") scol)) + (if stored (org-table-formula-to-user stored) "") + 'org-table-formula-history))))) mustsave) - (when (not (string-match "\\S-" eq)) - ;; remove formula + (unless (org-string-nw-p eq) + ;; Remove formula. (setq stored-list (delq (assoc scol stored-list) stored-list)) (org-table-store-formulas stored-list) (user-error "Formula removed")) - (if (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) - (if (string-match " *$" eq) (setq eq (replace-match "" t t eq))) - (if (and name (not named)) - ;; We set the column equation, delete the named one. - (setq stored-list (delq (assoc name stored-list) stored-list) - mustsave t)) + (when (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) + (when (string-match " *$" eq) (setq eq (replace-match "" t t eq))) + (when (and name (not named)) + ;; We set the column equation, delete the named one. + (setq stored-list (delq (assoc name stored-list) stored-list) + mustsave t)) (if stored (setcdr (assoc scol stored-list) eq) (setq stored-list (cons (cons scol eq) stored-list))) - (if (or mustsave (not (equal stored eq))) - (org-table-store-formulas stored-list)) + (when (or mustsave (not (equal stored eq))) + (org-table-store-formulas stored-list)) eq)) (defun org-table-store-formulas (alist &optional location) @@ -2348,7 +2160,7 @@ LOCATION is a buffer position, consider the formulas there." eq-alist seen) (dolist (string strings (nreverse eq-alist)) (when (string-match "\\`\\(@[-+I<>0-9.$@]+\\|\\$\\([_a-zA-Z0-9]+\\|\ -[<>]+\\)\\) *= *\\(.*[^ \t]\\)" +\[<>]+\\)\\) *= *\\(.*[^ \t]\\)" string) (let ((lhs (let ((m (match-string 1 string))) @@ -2425,19 +2237,6 @@ If yes, store the formula and apply it." (org-table-eval-formula (and named '(4)) (org-table-formula-from-user eq)))))) -(defvar org-recalc-commands nil - "List of commands triggering the recalculation of a line. -Will be filled automatically during use.") - -(defvar org-recalc-marks - '((" " . "Unmarked: no special line, no automatic recalculation") - ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") - ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") - ("!" . "Column name definition line. Reference in formula as $name.") - ("$" . "Parameter definition line name=value. Reference in formula as $name.") - ("_" . "Names for values in row below this one.") - ("^" . "Names for values in row above this one."))) - ;;;###autoload (defun org-table-rotate-recalc-marks (&optional newchar) "Rotate the recalculation mark in the first column. @@ -2509,141 +2308,6 @@ of the new mark." (message "%s" (cdr (assoc newchar org-recalc-marks)))))) ;;;###autoload -(defun org-table-analyze () - "Analyze table at point and store results. - -This function sets up the following dynamically scoped variables: - - `org-table-column-name-regexp', - `org-table-column-names', - `org-table-current-begin-pos', - `org-table-current-line-types', - `org-table-current-ncol', - `org-table-dlines', - `org-table-hlines', - `org-table-local-parameters', - `org-table-named-field-locations'." - (let ((beg (org-table-begin)) - (end (org-table-end))) - (save-excursion - (goto-char beg) - ;; Extract column names. - (setq org-table-column-names nil) - (when (save-excursion - (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t)) - (let ((c 1)) - (dolist (name (org-split-string (match-string 1) " *| *")) - (cl-incf c) - (when (string-match "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" name) - (push (cons name (int-to-string c)) org-table-column-names))))) - (setq org-table-column-names (nreverse org-table-column-names)) - (setq org-table-column-name-regexp - (format "\\$\\(%s\\)\\>" - (regexp-opt (mapcar #'car org-table-column-names) t))) - ;; Extract local parameters. - (setq org-table-local-parameters nil) - (save-excursion - (while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t) - (dolist (field (org-split-string (match-string 1) " *| *")) - (when (string-match - "\\`\\([a-zA-Z][_a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field) - (push (cons (match-string 1 field) (match-string 2 field)) - org-table-local-parameters))))) - ;; Update named fields locations. We minimize `count-lines' - ;; processing by storing last known number of lines in LAST. - (setq org-table-named-field-locations nil) - (save-excursion - (let ((last (cons (point) 0))) - (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) - (let ((c (match-string 1)) - (fields (org-split-string (match-string 2) " *| *"))) - (save-excursion - (forward-line (if (equal c "_") 1 -1)) - (let ((fields1 - (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") - (org-split-string (match-string 1) " *| *"))) - (line (cl-incf (cdr last) (count-lines (car last) (point)))) - (col 1)) - (setcar last (point)) ; Update last known position. - (while (and fields fields1) - (let ((field (pop fields)) - (v (pop fields1))) - (cl-incf col) - (when (and (stringp field) - (stringp v) - (string-match "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" - field)) - (push (cons field v) org-table-local-parameters) - (push (list field line col) - org-table-named-field-locations)))))))))) - ;; Re-use existing markers when possible. - (if (markerp org-table-current-begin-pos) - (move-marker org-table-current-begin-pos (point)) - (setq org-table-current-begin-pos (point-marker))) - ;; Analyze the line types. - (let ((l 0) hlines dlines types) - (while (looking-at "[ \t]*|\\(-\\)?") - (push (if (match-end 1) 'hline 'dline) types) - (if (match-end 1) (push l hlines) (push l dlines)) - (forward-line) - (cl-incf l)) - (push 'hline types) ; Add an imaginary extra hline to the end. - (setq org-table-current-line-types (apply #'vector (nreverse types))) - (setq org-table-dlines (apply #'vector (cons nil (nreverse dlines)))) - (setq org-table-hlines (apply #'vector (cons nil (nreverse hlines))))) - ;; Get the number of columns from the first data line in table. - (goto-char beg) - (forward-line (aref org-table-dlines 1)) - (let* ((fields - (org-split-string - (buffer-substring (line-beginning-position) (line-end-position)) - "[ \t]*|[ \t]*")) - (nfields (length fields)) - al al2) - (setq org-table-current-ncol nfields) - (let ((last-dline - (aref org-table-dlines (1- (length org-table-dlines))))) - (dotimes (i nfields) - (let ((column (1+ i))) - (push (list (format "LR%d" column) last-dline column) al) - (push (cons (format "LR%d" column) (nth i fields)) al2)))) - (setq org-table-named-field-locations - (append org-table-named-field-locations al)) - (setq org-table-local-parameters - (append org-table-local-parameters al2)))))) - -(defun org-table-goto-field (ref &optional create-column-p) - "Move point to a specific field in the current table. - -REF is either the name of a field its absolute reference, as -a string. No column is created unless CREATE-COLUMN-P is -non-nil. If it is a function, it is called with the column -number as its argument as is used as a predicate to know if the -column can be created. - -This function assumes the table is already analyzed (i.e., using -`org-table-analyze')." - (let* ((coordinates - (cond - ((cdr (assoc ref org-table-named-field-locations))) - ((string-match "\\`@\\([1-9][0-9]*\\)\\$\\([1-9][0-9]*\\)\\'" ref) - (list (condition-case nil - (aref org-table-dlines - (string-to-number (match-string 1 ref))) - (error (user-error "Invalid row number in %s" ref))) - (string-to-number (match-string 2 ref)))) - (t (user-error "Unknown field: %s" ref)))) - (line (car coordinates)) - (column (nth 1 coordinates)) - (create-new-column (if (functionp create-column-p) - (funcall create-column-p column) - create-column-p))) - (when coordinates - (goto-char org-table-current-begin-pos) - (forward-line line) - (org-table-goto-column column nil create-new-column)))) - -;;;###autoload (defun org-table-maybe-recalculate-line () "Recompute the current line if marked for it, and if we haven't just done it." (interactive) @@ -2654,19 +2318,6 @@ This function assumes the table is already analyzed (i.e., using (looking-at org-table-auto-recalculate-regexp)) (org-table-recalculate) t)) -(defvar org-tbl-calc-modes) ;; Dynamically bound in `org-table-eval-formula' -(defsubst org-set-calc-mode (var &optional value) - (if (stringp var) - (setq var (assoc var '(("D" calc-angle-mode deg) - ("R" calc-angle-mode rad) - ("F" calc-prefer-frac t) - ("S" calc-symbolic-mode t))) - value (nth 2 var) var (nth 1 var))) - (if (memq var org-tbl-calc-modes) - (setcar (cdr (memq var org-tbl-calc-modes)) value) - (cons var (cons value org-tbl-calc-modes))) - org-tbl-calc-modes) - ;;;###autoload (defun org-table-eval-formula (&optional arg equation suppress-align suppress-const @@ -2714,7 +2365,7 @@ SUPPRESS-ANALYSIS prevents analyzing the table and checking location of point." (interactive "P") (unless suppress-analysis - (org-table-check-inside-data-field) + (org-table-check-inside-data-field nil t) (org-table-analyze)) (if (equal arg '(16)) (let ((eq (org-table-current-field-formula))) @@ -2746,9 +2397,10 @@ location of point." (setq c (string-to-char (match-string 1 fmt)) n (string-to-number (match-string 2 fmt))) (if (= c ?p) - (setq org-tbl-calc-modes (org-set-calc-mode 'calc-internal-prec n)) + (setq org-tbl-calc-modes + (org-table--set-calc-mode 'calc-internal-prec n)) (setq org-tbl-calc-modes - (org-set-calc-mode + (org-table--set-calc-mode 'calc-float-format (list (cdr (assoc c '((?n . float) (?f . fix) (?s . sci) (?e . eng)))) @@ -2772,7 +2424,8 @@ location of point." (setq keep-empty t fmt (replace-match "" t t fmt))) (while (string-match "[DRFS]" fmt) - (setq org-tbl-calc-modes (org-set-calc-mode (match-string 0 fmt))) + (setq org-tbl-calc-modes + (org-table--set-calc-mode (match-string 0 fmt))) (setq fmt (replace-match "" t t fmt))) (unless (string-match "\\S-" fmt) (setq fmt nil)))) @@ -2909,8 +2562,8 @@ location of point." (format-time-string (org-time-stamp-format (string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" ts)) - (encode-time - (save-match-data (org-parse-time-string ts)))))) + (apply #'encode-time + (save-match-data (org-parse-time-string ts)))))) form t t)) (setq ev (if (and duration (string-match "^[0-9]+:[0-9]+\\(?::[0-9]+\\)?$" form)) @@ -3169,7 +2822,7 @@ ARGS are passed as arguments to the `message' function. Returns current time if a message is printed, otherwise returns T1. If T1 is nil, always messages." (let ((curtime (current-time))) - (if (or (not t1) (time-less-p 1 (time-subtract curtime t1))) + (if (or (not t1) (org-time-less-p 1 (org-time-subtract curtime t1))) (progn (apply 'message args) curtime) t1))) @@ -3204,139 +2857,139 @@ known that the table will be realigned a little later anyway." beg end eqlcol eqlfield) ;; Insert constants in all formulas. (when eqlist - (org-table-save-field - ;; Expand equations, then split the equation list between - ;; column formulas and field formulas. - (dolist (eq eqlist) - (let* ((rhs (org-table-formula-substitute-names - (org-table-formula-handle-first/last-rc (cdr eq)))) - (old-lhs (car eq)) - (lhs - (org-table-formula-handle-first/last-rc - (cond - ((string-match "\\`@-?I+" old-lhs) - (user-error "Can't assign to hline relative reference")) - ((string-match "\\`\\$[<>]" old-lhs) - (let ((new (org-table-formula-handle-first/last-rc - old-lhs))) - (when (assoc new eqlist) - (user-error "\"%s=\" formula tries to overwrite \ + (org-table-with-shrunk-columns + (org-table-save-field + ;; Expand equations, then split the equation list between + ;; column formulas and field formulas. + (dolist (eq eqlist) + (let* ((rhs (org-table-formula-substitute-names + (org-table-formula-handle-first/last-rc (cdr eq)))) + (old-lhs (car eq)) + (lhs + (org-table-formula-handle-first/last-rc + (cond + ((string-match "\\`@-?I+" old-lhs) + (user-error "Can't assign to hline relative reference")) + ((string-match "\\`\\$[<>]" old-lhs) + (let ((new (org-table-formula-handle-first/last-rc + old-lhs))) + (when (assoc new eqlist) + (user-error "\"%s=\" formula tries to overwrite \ existing formula for column %s" - old-lhs - new)) - new)) - (t old-lhs))))) - (if (string-match-p "\\`\\$[0-9]+\\'" lhs) - (push (cons lhs rhs) eqlcol) - (push (cons lhs rhs) eqlfield)))) - (setq eqlcol (nreverse eqlcol)) - ;; Expand ranges in lhs of formulas - (setq eqlfield (org-table-expand-lhs-ranges (nreverse eqlfield))) - ;; Get the correct line range to process. - (if all - (progn - (setq end (copy-marker (org-table-end))) - (goto-char (setq beg org-table-current-begin-pos)) - (cond - ((re-search-forward org-table-calculate-mark-regexp end t) - ;; This is a table with marked lines, compute selected - ;; lines. - (setq line-re org-table-recalculate-regexp)) - ;; Move forward to the first non-header line. - ((and (re-search-forward org-table-dataline-regexp end t) - (re-search-forward org-table-hline-regexp end t) - (re-search-forward org-table-dataline-regexp end t)) - (setq beg (match-beginning 0))) - ;; Just leave BEG at the start of the table. - (t nil))) - (setq beg (line-beginning-position) - end (copy-marker (line-beginning-position 2)))) - (goto-char beg) - ;; Mark named fields untouchable. Also check if several - ;; field/range formulas try to set the same field. - (remove-text-properties beg end '(:org-untouchable t)) - (let ((current-line (count-lines org-table-current-begin-pos - (line-beginning-position))) - seen-fields) - (dolist (eq eqlfield) - (let* ((name (car eq)) - (location (assoc name org-table-named-field-locations)) - (eq-line (or (nth 1 location) - (and (string-match "\\`@\\([0-9]+\\)" name) - (aref org-table-dlines - (string-to-number - (match-string 1 name)))))) - (reference - (if location - ;; Turn field coordinates associated to NAME - ;; into an absolute reference. - (format "@%d$%d" - (org-table-line-to-dline eq-line) - (nth 2 location)) - name))) - (when (member reference seen-fields) - (user-error "Several field/range formulas try to set %s" - reference)) - (push reference seen-fields) - (when (or all (eq eq-line current-line)) - (org-table-goto-field name) - (org-table-put-field-property :org-untouchable t))))) - ;; Evaluate the column formulas, but skip fields covered by - ;; field formulas. - (goto-char beg) - (while (re-search-forward line-re end t) - (unless (string-match "\\` *[_^!$/] *\\'" (org-table-get-field 1)) - ;; Unprotected line, recalculate. - (cl-incf cnt) - (when all - (setq log-last-time - (org-table-message-once-per-second - log-last-time - "Re-applying formulas to full table...(line %d)" cnt))) - (if (markerp org-last-recalc-line) - (move-marker org-last-recalc-line (line-beginning-position)) - (setq org-last-recalc-line - (copy-marker (line-beginning-position)))) - (dolist (entry eqlcol) - (goto-char org-last-recalc-line) - (org-table-goto-column - (string-to-number (substring (car entry) 1)) nil 'force) - (unless (get-text-property (point) :org-untouchable) - (org-table-eval-formula - nil (cdr entry) 'noalign 'nocst 'nostore 'noanalysis))))) - ;; Evaluate the field formulas. - (dolist (eq eqlfield) - (let ((reference (car eq)) - (formula (cdr eq))) - (setq log-last-time - (org-table-message-once-per-second - (and all log-last-time) - "Re-applying formula to field: %s" (car eq))) - (org-table-goto-field - reference - ;; Possibly create a new column, as long as - ;; `org-table-formula-create-columns' allows it. - (let ((column-count (progn (end-of-line) - (1- (org-table-current-column))))) - (lambda (column) - (when (> column 1000) - (user-error "Formula column target too large")) - (and (> column column-count) - (or (eq org-table-formula-create-columns t) - (and (eq org-table-formula-create-columns 'warn) - (progn - (org-display-warning - "Out-of-bounds formula added columns") - t)) - (and (eq org-table-formula-create-columns 'prompt) - (yes-or-no-p - "Out-of-bounds formula. Add columns? ")) - (user-error - "Missing columns in the table. Aborting")))))) - (org-table-eval-formula nil formula t t t t)))) - ;; Clean up markers and internal text property. - (remove-text-properties (point-min) (point-max) '(org-untouchable t)) - (set-marker end nil) + old-lhs + new)) + new)) + (t old-lhs))))) + (if (string-match-p "\\`\\$[0-9]+\\'" lhs) + (push (cons lhs rhs) eqlcol) + (push (cons lhs rhs) eqlfield)))) + (setq eqlcol (nreverse eqlcol)) + ;; Expand ranges in lhs of formulas + (setq eqlfield (org-table-expand-lhs-ranges (nreverse eqlfield))) + ;; Get the correct line range to process. + (if all + (progn + (setq end (copy-marker (org-table-end))) + (goto-char (setq beg org-table-current-begin-pos)) + (cond + ((re-search-forward org-table-calculate-mark-regexp end t) + ;; This is a table with marked lines, compute selected + ;; lines. + (setq line-re org-table-recalculate-regexp)) + ;; Move forward to the first non-header line. + ((and (re-search-forward org-table-dataline-regexp end t) + (re-search-forward org-table-hline-regexp end t) + (re-search-forward org-table-dataline-regexp end t)) + (setq beg (match-beginning 0))) + ;; Just leave BEG at the start of the table. + (t nil))) + (setq beg (line-beginning-position) + end (copy-marker (line-beginning-position 2)))) + (goto-char beg) + ;; Mark named fields untouchable. Also check if several + ;; field/range formulas try to set the same field. + (remove-text-properties beg end '(:org-untouchable t)) + (let ((current-line (count-lines org-table-current-begin-pos + (line-beginning-position))) + seen-fields) + (dolist (eq eqlfield) + (let* ((name (car eq)) + (location (assoc name org-table-named-field-locations)) + (eq-line (or (nth 1 location) + (and (string-match "\\`@\\([0-9]+\\)" name) + (aref org-table-dlines + (string-to-number + (match-string 1 name)))))) + (reference + (if location + ;; Turn field coordinates associated to NAME + ;; into an absolute reference. + (format "@%d$%d" + (org-table-line-to-dline eq-line) + (nth 2 location)) + name))) + (when (member reference seen-fields) + (user-error "Several field/range formulas try to set %s" + reference)) + (push reference seen-fields) + (when (or all (eq eq-line current-line)) + (org-table-goto-field name) + (org-table-put-field-property :org-untouchable t))))) + ;; Evaluate the column formulas, but skip fields covered by + ;; field formulas. + (goto-char beg) + (while (re-search-forward line-re end t) + (unless (string-match "\\` *[_^!$/] *\\'" (org-table-get-field 1)) + ;; Unprotected line, recalculate. + (cl-incf cnt) + (when all + (setq log-last-time + (org-table-message-once-per-second + log-last-time + "Re-applying formulas to full table...(line %d)" cnt))) + (if (markerp org-last-recalc-line) + (move-marker org-last-recalc-line (line-beginning-position)) + (setq org-last-recalc-line + (copy-marker (line-beginning-position)))) + (dolist (entry eqlcol) + (goto-char org-last-recalc-line) + (org-table-goto-column + (string-to-number (substring (car entry) 1)) nil 'force) + (unless (get-text-property (point) :org-untouchable) + (org-table-eval-formula + nil (cdr entry) 'noalign 'nocst 'nostore 'noanalysis))))) + ;; Evaluate the field formulas. + (dolist (eq eqlfield) + (let ((reference (car eq)) + (formula (cdr eq))) + (setq log-last-time + (org-table-message-once-per-second + (and all log-last-time) + "Re-applying formula to field: %s" (car eq))) + (org-table-goto-field + reference + ;; Possibly create a new column, as long as + ;; `org-table-formula-create-columns' allows it. + (let ((column-count (progn (end-of-line) + (1- (org-table-current-column))))) + (lambda (column) + (when (> column 1000) + (user-error "Formula column target too large")) + (and (> column column-count) + (or (eq org-table-formula-create-columns t) + (and (eq org-table-formula-create-columns 'warn) + (progn + (org-display-warning + "Out-of-bounds formula added columns") + t)) + (and (eq org-table-formula-create-columns 'prompt) + (yes-or-no-p + "Out-of-bounds formula. Add columns? ")) + (user-error + "Missing columns in the table. Aborting")))))) + (org-table-eval-formula nil formula t t t t))) + ;; Clean up marker. + (set-marker end nil))) (unless noalign (when org-table-may-need-update (org-table-align)) (when all @@ -3597,7 +3250,6 @@ Parameters get priority." ["Standard Refs (B3 instead of @3$2)" org-table-fedit-toggle-ref-type :style toggle :selected org-table-buffer-is-an])) -(defvar org-pos) (defvar org-table--fedit-source nil "Position of the TBLFM line being edited.") @@ -3830,44 +3482,47 @@ minutes or seconds." "Shift the reference at point one row/hline up." (interactive) (org-table-fedit-shift-reference 'up)) + (defun org-table-fedit-ref-down () "Shift the reference at point one row/hline down." (interactive) (org-table-fedit-shift-reference 'down)) + (defun org-table-fedit-ref-left () "Shift the reference at point one field to the left." (interactive) (org-table-fedit-shift-reference 'left)) + (defun org-table-fedit-ref-right () "Shift the reference at point one field to the right." (interactive) (org-table-fedit-shift-reference 'right)) +(defun org-table--rematch-and-replace (n &optional decr hline) + "Re-match the group N, and replace it with the shifted reference." + (or (match-end n) (user-error "Cannot shift reference in this direction")) + (goto-char (match-beginning n)) + (and (looking-at (regexp-quote (match-string n))) + (replace-match (org-table-shift-refpart (match-string 0) decr hline) + t t))) + (defun org-table-fedit-shift-reference (dir) (cond ((org-in-regexp "\\(\\<[a-zA-Z]\\)&") (if (memq dir '(left right)) - (org-rematch-and-replace 1 (eq dir 'left)) + (org-table--rematch-and-replace 1 (eq dir 'left)) (user-error "Cannot shift reference in this direction"))) ((org-in-regexp "\\(\\<[a-zA-Z]\\{1,2\\}\\)\\([0-9]+\\)") ;; A B3-like reference (if (memq dir '(up down)) - (org-rematch-and-replace 2 (eq dir 'up)) - (org-rematch-and-replace 1 (eq dir 'left)))) + (org-table--rematch-and-replace 2 (eq dir 'up)) + (org-table--rematch-and-replace 1 (eq dir 'left)))) ((org-in-regexp "\\(@\\|\\.\\.\\)\\([-+]?\\(I+\\>\\|[0-9]+\\)\\)\\(\\$\\([-+]?[0-9]+\\)\\)?") ;; An internal reference (if (memq dir '(up down)) - (org-rematch-and-replace 2 (eq dir 'up) (match-end 3)) - (org-rematch-and-replace 5 (eq dir 'left)))))) - -(defun org-rematch-and-replace (n &optional decr hline) - "Re-match the group N, and replace it with the shifted reference." - (or (match-end n) (user-error "Cannot shift reference in this direction")) - (goto-char (match-beginning n)) - (and (looking-at (regexp-quote (match-string n))) - (replace-match (org-table-shift-refpart (match-string 0) decr hline) - t t))) + (org-table--rematch-and-replace 2 (eq dir 'up) (match-end 3)) + (org-table--rematch-and-replace 5 (eq dir 'left)))))) (defun org-table-shift-refpart (ref &optional decr hline) "Shift a reference part REF. @@ -3995,7 +3650,1207 @@ With prefix ARG, apply the new formulas to the table." (goto-char beg)) (t nil)))) -(defvar org-show-positions nil) +(defun org-table-fedit-line-up () + "Move cursor one line up in the window showing the table." + (interactive) + (org-table-fedit-move 'previous-line)) + +(defun org-table-fedit-line-down () + "Move cursor one line down in the window showing the table." + (interactive) + (org-table-fedit-move 'next-line)) + +(defun org-table-fedit-move (command) + "Move the cursor in the window showing the table. +Use COMMAND to do the motion, repeat if necessary to end up in a data line." + (let ((org-table-allow-automatic-line-recalculation nil) + (pos org-pos) (win (selected-window)) p) + (select-window (get-buffer-window (marker-buffer org-pos))) + (setq p (point)) + (call-interactively command) + (while (and (org-at-table-p) + (org-at-table-hline-p)) + (call-interactively command)) + (or (org-at-table-p) (goto-char p)) + (move-marker pos (point)) + (select-window win))) + +(defun org-table-fedit-scroll (N) + (interactive "p") + (let ((other-window-scroll-buffer (marker-buffer org-pos))) + (scroll-other-window N))) + +(defun org-table-fedit-scroll-down (N) + (interactive "p") + (org-table-fedit-scroll (- N))) + +(defun org-table-add-rectangle-overlay (beg end &optional face) + "Add a new overlay." + (let ((ov (make-overlay beg end))) + (overlay-put ov 'face (or face 'secondary-selection)) + (push ov org-table-rectangle-overlays))) + +(defun org-table-highlight-rectangle (&optional beg end face) + "Highlight rectangular region in a table. +When buffer positions BEG and END are provided, use them to +delimit the region to highlight. Otherwise, refer to point. Use +FACE, when non-nil, for the highlight." + (let* ((beg (or beg (point))) + (end (or end (point))) + (b (min beg end)) + (e (max beg end)) + (start-coordinates + (save-excursion + (goto-char b) + (cons (line-beginning-position) (org-table-current-column)))) + (end-coordinates + (save-excursion + (goto-char e) + (cons (line-beginning-position) (org-table-current-column))))) + (when (boundp 'org-show-positions) + (setq org-show-positions (cons b (cons e org-show-positions)))) + (goto-char (car start-coordinates)) + (let ((column-start (min (cdr start-coordinates) (cdr end-coordinates))) + (column-end (max (cdr start-coordinates) (cdr end-coordinates))) + (last-row (car end-coordinates))) + (while (<= (point) last-row) + (when (looking-at org-table-dataline-regexp) + (org-table-goto-column column-start) + (skip-chars-backward "^|\n") + (let ((p (point))) + (org-table-goto-column column-end) + (skip-chars-forward "^|\n") + (org-table-add-rectangle-overlay p (point) face))) + (forward-line))) + (goto-char (car start-coordinates))) + (add-hook 'before-change-functions #'org-table-remove-rectangle-highlight)) + +(defun org-table-remove-rectangle-highlight (&rest _ignore) + "Remove the rectangle overlays." + (unless org-inhibit-highlight-removal + (remove-hook 'before-change-functions 'org-table-remove-rectangle-highlight) + (mapc 'delete-overlay org-table-rectangle-overlays) + (setq org-table-rectangle-overlays nil))) + +(defvar-local org-table-coordinate-overlays nil + "Collects the coordinate grid overlays, so that they can be removed.") + +(defun org-table-overlay-coordinates () + "Add overlays to the table at point, to show row/column coordinates." + (interactive) + (mapc 'delete-overlay org-table-coordinate-overlays) + (setq org-table-coordinate-overlays nil) + (save-excursion + (let ((id 0) (ih 0) hline eol str ov) + (goto-char (org-table-begin)) + (while (org-at-table-p) + (setq eol (point-at-eol)) + (setq ov (make-overlay (point-at-bol) (1+ (point-at-bol)))) + (push ov org-table-coordinate-overlays) + (setq hline (looking-at org-table-hline-regexp)) + (setq str (if hline (format "I*%-2d" (setq ih (1+ ih))) + (format "%4d" (setq id (1+ id))))) + (org-overlay-before-string ov str 'org-special-keyword 'evaporate) + (when hline + (let ((ic 0)) + (while (re-search-forward "[+|]\\(-+\\)" eol t) + (cl-incf ic) + (let* ((beg (1+ (match-beginning 0))) + (s1 (format "$%d" ic)) + (s2 (org-number-to-letters ic)) + (str (if (eq t org-table-use-standard-references) s2 s1)) + (ov (make-overlay beg (+ beg (length str))))) + (push ov org-table-coordinate-overlays) + (org-overlay-display ov str 'org-special-keyword 'evaporate))))) + (forward-line))))) + +;;;###autoload +(defun org-table-toggle-coordinate-overlays () + "Toggle the display of Row/Column numbers in tables." + (interactive) + (setq org-table-overlay-coordinates (not org-table-overlay-coordinates)) + (message "Tables Row/Column numbers display turned %s" + (if org-table-overlay-coordinates "on" "off")) + (when (and (org-at-table-p) org-table-overlay-coordinates) + (org-table-align)) + (unless org-table-overlay-coordinates + (mapc 'delete-overlay org-table-coordinate-overlays) + (setq org-table-coordinate-overlays nil))) + +;;;###autoload +(defun org-table-toggle-formula-debugger () + "Toggle the formula debugger in tables." + (interactive) + (setq org-table-formula-debug (not org-table-formula-debug)) + (message "Formula debugging has been turned %s" + (if org-table-formula-debug "on" "off"))) + + +;;; Columns Shrinking + +(defun org-table--shrunk-field () + "Non-nil if current field is narrowed. +When non-nil, return the overlay narrowing the field." + (cl-some (lambda (o) + (and (eq 'table-column-hide (overlay-get o 'org-overlay-type)) + o)) + (overlays-at (save-excursion + (skip-chars-forward (if (org-at-table-hline-p) "^+|" + "^|") + (line-end-position)) + (1- (point)))))) + +(defun org-table--list-shrunk-columns () + "List currently shrunk columns in table at point." + (save-excursion + ;; We really check shrunk columns in current row only. It could + ;; be wrong if all rows do not contain the same number of columns + ;; (i.e. the table is not properly aligned). As a consequence, + ;; some columns may not be shrunk again upon aligning the table. + ;; + ;; For example, in the following table, cursor is on first row and + ;; "<>" indicates a shrunk column. + ;; + ;; | | + ;; | | <> | + ;; + ;; Aligning table from the first row will not shrink again the + ;; second row, which was not visible initially. + ;; + ;; However, fixing it requires to check every row, which may be + ;; slow on large tables. Moreover, the hindrance of this + ;; pathological case is very limited. + (beginning-of-line) + (search-forward "|") + (let ((separator (if (org-at-table-hline-p) "+" "|")) + (column 1) + (shrunk (and (org-table--shrunk-field) (list 1))) + (end (line-end-position))) + (while (search-forward separator end t) + (cl-incf column) + (when (org-table--shrunk-field) (push column shrunk))) + (nreverse shrunk)))) + +(defun org-table--make-shrinking-overlay (start end display field &optional pre) + "Create an overlay to shrink text between START and END. + +Use string DISPLAY instead of the real text between the two +buffer positions. FIELD is the real contents of the field, as +a string, or nil. It is meant to be displayed upon moving the +mouse onto the overlay. + +When optional argument PRE is non-nil, assume the overlay is +located at the beginning of the field, and prepend +`org-table-separator-space' to it. Otherwise, concatenate +`org-table-shrunk-column-indicator' at its end. + +Return the overlay." + (let ((show-before-edit + (lambda (o &rest _) + ;; Removing one overlay removes all other overlays in the + ;; same column. + (mapc #'delete-overlay + (cdr (overlay-get o 'org-table-column-overlays))))) + (o (make-overlay start end))) + (overlay-put o 'insert-behind-hooks (list show-before-edit)) + (overlay-put o 'insert-in-front-hooks (list show-before-edit)) + (overlay-put o 'modification-hooks (list show-before-edit)) + (overlay-put o 'org-overlay-type 'table-column-hide) + (when (stringp field) (overlay-put o 'help-echo field)) + ;; Make sure overlays stays on top of table coordinates overlays. + ;; See `org-table-overlay-coordinates'. + (overlay-put o 'priority 1) + (let ((d (if pre (concat org-table-separator-space display) + (concat display org-table-shrunk-column-indicator)))) + (org-overlay-display o d 'org-table t)) + o)) + +(defun org-table--shrink-field (width align start end contents) + "Shrink a table field to a specified width. + +WIDTH is an integer representing the number of characters to +display, in addition to `org-table-shrunk-column-indicator'. +ALIGN is the alignment of the current column, as either \"l\", +\"c\" or \"r\". START and END are, respectively, the beginning +and ending positions of the field. CONTENTS is its trimmed +contents, as a string, or `hline' for table rules. + +Real field is hidden under one or two overlays. They have the +following properties: + + `org-overlay-type' + + Set to `table-column-hide'. Used to identify overlays + responsible for shrinking columns in a table. + + `org-table-column-overlays' + + It is a list with the pattern (siblings . COLUMN-OVERLAYS) + where COLUMN-OVERLAYS is the list of all overlays hiding the + same column. + +Whenever the text behind or next to the overlay is modified, all +the overlays in the column are deleted, effectively displaying +the column again. + +Return a list of overlays hiding the field, or nil if field is +already hidden." + (cond + ((= start end) nil) ;no field to narrow + ((org-table--shrunk-field) nil) ;already shrunk + ((= 0 width) ;shrink to one character + (list (org-table--make-shrinking-overlay + start end "" (if (eq 'hline contents) "" contents)))) + ((eq contents 'hline) + (list (org-table--make-shrinking-overlay + start end (make-string (1+ width) ?-) ""))) + ((equal contents "") ;no contents to hide + (list + (let ((w (org-string-width (buffer-substring start end))) + ;; We really want WIDTH + 2 whitespace, to include blanks + ;; around fields. + (full (+ 2 width))) + (if (<= w full) + (org-table--make-shrinking-overlay + (1- end) end (make-string (- full w) ?\s) "") + (org-table--make-shrinking-overlay (- end (- w full) 1) end "" ""))))) + (t + ;; If the field is not empty, display exactly WIDTH characters. + ;; It can mean to partly hide the field, or extend it with virtual + ;; blanks. To that effect, we use one or two overlays. The + ;; first, optional, one may add or hide white spaces before the + ;; contents of the field. The other, mandatory, one cuts the + ;; field or displays white spaces at the end of the field. It + ;; also always displays `org-table-shrunk-column-indicator'. + (let* ((lead (org-with-point-at start (skip-chars-forward " "))) + (trail (org-with-point-at end (abs (skip-chars-backward " ")))) + (contents-width (org-string-width + (buffer-substring (+ start lead) (- end trail))))) + (cond + ;; Contents are too large to fit in WIDTH character. Limit, if + ;; possible, blanks at the beginning of the field to a single + ;; white space, and cut the field at an appropriate location. + ((<= width contents-width) + (let ((pre + (and (> lead 0) + (org-table--make-shrinking-overlay + start (+ start lead) "" contents t))) + (post + (org-table--make-shrinking-overlay + ;; Find cut location so that WIDTH characters are + ;; visible using dichotomy. + (let* ((begin (+ start lead)) + (lower begin) + (upper (1- end)) + ;; Compensate the absence of leading space, + ;; thus preserving alignment. + (width (if (= lead 0) (1+ width) width))) + (catch :exit + (while (> (- upper lower) 1) + (let ((mean (+ (ash lower -1) + (ash upper -1) + (logand lower upper 1)))) + (pcase (org-string-width (buffer-substring begin mean)) + ((pred (= width)) (throw :exit mean)) + ((pred (< width)) (setq upper mean)) + (_ (setq lower mean))))) + upper)) + end "" contents))) + (if pre (list pre post) (list post)))) + ;; Contents fit it WIDTH characters. First compute number of + ;; white spaces needed on each side of contents, then expand or + ;; compact blanks on each side of the field in order to + ;; preserve width and obey to alignment constraints. + (t + (let* ((required (- width contents-width)) + (before + (pcase align + ;; Compensate the absence of leading space, thus + ;; preserving alignment. + ((guard (= lead 0)) -1) + ("l" 0) + ("r" required) + ("c" (/ required 2)))) + (after (- required before)) + (pre + (pcase (1- lead) + ((or (guard (= lead 0)) (pred (= before))) nil) + ((pred (< before)) + (org-table--make-shrinking-overlay + start (+ start (- lead before)) "" contents t)) + (_ + (org-table--make-shrinking-overlay + start (1+ start) + (make-string (- before (1- lead)) ?\s) + contents t)))) + (post + (pcase (1- trail) + ((pred (= after)) + (org-table--make-shrinking-overlay (1- end) end "" contents)) + ((pred (< after)) + (org-table--make-shrinking-overlay + (+ after (- end trail)) end "" contents)) + (_ + (org-table--make-shrinking-overlay + (1- end) end + (make-string (- after (1- trail)) ?\s) + contents))))) + (if pre (list pre post) (list post))))))))) + +(defun org-table--read-column-selection (select max) + "Read column selection select as a list of numbers. + +SELECT is a string containing column ranges, separated by white +space characters, see `org-table-hide-column' for details. MAX +is the maximum column number. + +Return value is a sorted list of numbers. Ignore any number +outside of the [1;MAX] range." + (catch :all + (sort + (delete-dups + (cl-mapcan + (lambda (s) + (cond + ((member s '("-" "1-")) (throw :all (number-sequence 1 max))) + ((string-match-p "\\`[0-9]+\\'" s) + (let ((n (string-to-number s))) + (and (> n 0) (<= n max) (list n)))) + ((string-match "\\`\\([0-9]+\\)?-\\([0-9]+\\)?\\'" s) + (let ((n (match-string 1 s)) + (m (match-string 2 s))) + (number-sequence (if n (max 1 (string-to-number n)) + 1) + (if m (min max (string-to-number m)) + max)))) + (t nil))) ;invalid specification + (split-string select))) + #'<))) + +(defun org-table--shrink-columns (columns beg end) + "Shrink COLUMNS in a table. +COLUMNS is a sorted list of column numbers. BEG and END are, +respectively, the beginning position and the end position of the +table." + (org-with-wide-buffer + (org-font-lock-ensure beg end) + (dolist (c columns) + (goto-char beg) + (let ((align nil) + (width nil) + (fields nil)) + (while (< (point) end) + (catch :continue + (let* ((hline? (org-at-table-hline-p)) + (separator (if hline? "+" "|"))) + ;; Move to COLUMN. + (search-forward "|") + (or (= c 1) ;already there + (search-forward separator (line-end-position) t (1- c)) + (throw :continue nil)) ;skip invalid columns + ;; Extract boundaries and contents from current field. + ;; Also set the column's width if we encounter a width + ;; cookie for the first time. + (let* ((start (point)) + (end (progn + (skip-chars-forward (concat "^|" separator) + (line-end-position)) + (point))) + (contents (if hline? 'hline + (org-trim (buffer-substring start end))))) + (push (list start end contents) fields) + (when (and (not hline?) + (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)>\\'" + contents)) + (unless align (setq align (match-string 1 contents))) + (unless width + (setq width (string-to-number (match-string 2 contents)))))))) + (forward-line)) + ;; Link overlays for current field to the other overlays in the + ;; same column. + (let ((chain (list 'siblings))) + (dolist (field fields) + (dolist (new (apply #'org-table--shrink-field + (or width 0) (or align "l") field)) + (push new (cdr chain)) + (overlay-put new 'org-table-column-overlays chain)))))))) + +;;;###autoload +(defun org-table-toggle-column-width (&optional arg) + "Shrink or expand current column in an Org table. + +If a width cookie specifies a width W for the column, the first +W visible characters are displayed. Otherwise, the column is +shrunk to a single character. + +When point is before the first column or after the last one, ask +for the columns to shrink or expand, as a list of ranges. +A column range can be one of the following patterns: + + N column N only + N-M every column between N and M (both inclusive) + N- every column between N (inclusive) and the last column + -M every column between the first one and M (inclusive) + - every column + +When optional argument ARG is a string, use it as white space +separated list of column ranges. + +When called with `\\[universal-argument]' prefix, call \ +`org-table-shrink', i.e., +shrink columns with a width cookie and expand the others. + +When called with `\\[universal-argument] \\[universal-argument]' \ +prefix, expand all columns." + (interactive "P") + (unless (org-at-table-p) (user-error "Not in a table")) + (let* ((begin (org-table-begin)) + (end (org-table-end)) + ;; Compute an upper bound for the number of columns. + ;; Nonexistent columns are ignored anyway. + (max-columns (/ (- (line-end-position) (line-beginning-position)) 2)) + (shrunk (org-table--list-shrunk-columns)) + (columns + (pcase arg + (`nil + (if (save-excursion + (skip-chars-backward "^|" (line-beginning-position)) + (or (bolp) (looking-at-p "[ \t]*$"))) + ;; Point is either before first column or past last + ;; one. Ask for columns to operate on. + (org-table--read-column-selection + (read-string "Column ranges (e.g. 2-4 6-): ") + max-columns) + (list (org-table-current-column)))) + ((pred stringp) (org-table--read-column-selection arg max-columns)) + ((or `(4) `(16)) nil) + (_ (user-error "Invalid argument: %S" arg))))) + (pcase arg + (`(4) (org-table-shrink begin end)) + (`(16) (org-table-expand begin end)) + (_ + (org-table-expand begin end) + (org-table--shrink-columns + (cl-set-exclusive-or columns shrunk) begin end))))) + +;;;###autoload +(defun org-table-shrink (&optional begin end) + "Shrink all columns with a width cookie in the table at point. + +Columns without a width cookie are expanded. + +Optional arguments BEGIN and END, when non-nil, specify the +beginning and end position of the current table." + (interactive) + (unless (or begin (org-at-table-p)) (user-error "Not at a table")) + (org-with-wide-buffer + (let ((begin (or begin (org-table-begin))) + (end (or end (org-table-end))) + (regexp "|[ \t]*<[lrc]?[0-9]+>[ \t]*\\(|\\|$\\)") + (columns)) + (goto-char begin) + (while (re-search-forward regexp end t) + (goto-char (match-beginning 1)) + (cl-pushnew (org-table-current-column) columns)) + (org-table-expand begin end) + ;; Make sure invisible characters in the table are at the right + ;; place since column widths take them into account. + (org-font-lock-ensure begin end) + (org-table--shrink-columns (sort columns #'<) begin end)))) + +;;;###autoload +(defun org-table-expand (&optional begin end) + "Expand all columns in the table at point. +Optional arguments BEGIN and END, when non-nil, specify the +beginning and end position of the current table." + (interactive) + (unless (or begin (org-at-table-p)) (user-error "Not at a table")) + (org-with-wide-buffer + (let ((begin (or begin (org-table-begin))) + (end (or end (org-table-end)))) + (remove-overlays begin end 'org-overlay-type 'table-column-hide)))) + + +;;; Generic Tools + +;;;###autoload +(defun org-table-map-tables (f &optional quietly) + "Apply function F to the start of all tables in the buffer." + (org-with-point-at 1 + (while (re-search-forward org-table-line-regexp nil t) + (let ((table (org-element-lineage (org-element-at-point) '(table) t))) + (when table + (unless quietly + (message "Mapping tables: %d%%" + (floor (* 100.0 (point)) (buffer-size)))) + (goto-char (org-element-property :post-affiliated table)) + (let ((end (copy-marker (org-element-property :end table)))) + (unwind-protect + (progn (funcall f) (goto-char end)) + (set-marker end nil))))))) + (unless quietly (message "Mapping tables: done"))) + +;;;###autoload +(defun org-table-export (&optional file format) + "Export table to a file, with configurable format. +Such a file can be imported into usual spreadsheet programs. + +FILE can be the output file name. If not given, it will be taken +from a TABLE_EXPORT_FILE property in the current entry or higher +up in the hierarchy, or the user will be prompted for a file +name. FORMAT can be an export format, of the same kind as it +used when `-mode' sends a table in a different format. + +The command suggests a format depending on TABLE_EXPORT_FORMAT, +whether it is set locally or up in the hierarchy, then on the +extension of the given file name, and finally on the variable +`org-table-export-default-format'." + (interactive) + (unless (org-at-table-p) (user-error "No table at point")) + (org-table-align) ; Make sure we have everything we need. + (let ((file (or file (org-entry-get (point) "TABLE_EXPORT_FILE" t)))) + (unless file + (setq file (read-file-name "Export table to: ")) + (unless (or (not (file-exists-p file)) + (y-or-n-p (format "Overwrite file %s? " file))) + (user-error "File not written"))) + (when (file-directory-p file) + (user-error "This is a directory path, not a file")) + (when (and (buffer-file-name (buffer-base-buffer)) + (file-equal-p + (file-truename file) + (file-truename (buffer-file-name (buffer-base-buffer))))) + (user-error "Please specify a file name that is different from current")) + (let ((fileext (concat (file-name-extension file) "$")) + (format (or format (org-entry-get (point) "TABLE_EXPORT_FORMAT" t)))) + (unless format + (let* ((formats '("orgtbl-to-tsv" "orgtbl-to-csv" "orgtbl-to-latex" + "orgtbl-to-html" "orgtbl-to-generic" + "orgtbl-to-texinfo" "orgtbl-to-orgtbl" + "orgtbl-to-unicode")) + (deffmt-readable + (replace-regexp-in-string + "\t" "\\t" + (replace-regexp-in-string + "\n" "\\n" + (or (car (delq nil + (mapcar + (lambda (f) + (and (string-match-p fileext f) f)) + formats))) + org-table-export-default-format) + t t) t t))) + (setq format + (org-completing-read + "Format: " formats nil nil deffmt-readable)))) + (if (string-match "\\([^ \t\r\n]+\\)\\( +.*\\)?" format) + (let ((transform (intern (match-string 1 format))) + (params (and (match-end 2) + (read (concat "(" (match-string 2 format) ")")))) + (table (org-table-to-lisp + (buffer-substring-no-properties + (org-table-begin) (org-table-end))))) + (unless (fboundp transform) + (user-error "No such transformation function %s" transform)) + (let (buf) + (with-current-buffer (find-file-noselect file) + (setq buf (current-buffer)) + (erase-buffer) + (fundamental-mode) + (insert (funcall transform table params) "\n") + (save-buffer)) + (kill-buffer buf)) + (message "Export done.")) + (user-error "TABLE_EXPORT_FORMAT invalid"))))) + +;;;###autoload +(defun org-table--align-field (field width align) + "Format FIELD according to column WIDTH and alignment ALIGN. +FIELD is a string. WIDTH is a number. ALIGN is either \"c\", +\"l\" or\"r\"." + (let* ((spaces (- width (org-string-width field))) + (prefix (pcase align + ("l" "") + ("r" (make-string spaces ?\s)) + ("c" (make-string (/ spaces 2) ?\s)))) + (suffix (make-string (- spaces (length prefix)) ?\s))) + (concat org-table-separator-space + prefix + field + suffix + org-table-separator-space))) + +(defun org-table-align () + "Align the table at point by aligning all vertical bars." + (interactive) + (let ((beg (org-table-begin)) + (end (copy-marker (org-table-end)))) + (org-table-save-field + ;; Make sure invisible characters in the table are at the right + ;; place since column widths take them into account. + (org-font-lock-ensure beg end) + (move-marker org-table-aligned-begin-marker beg) + (move-marker org-table-aligned-end-marker end) + (goto-char beg) + (org-table-with-shrunk-columns + (let* ((indent (progn (looking-at "[ \t]*") (match-string 0))) + ;; Table's rows as lists of fields. Rules are replaced + ;; by nil. Trailing spaces are removed. + (fields (mapcar + (lambda (l) + (and (not (string-match-p org-table-hline-regexp l)) + (org-split-string l "[ \t]*|[ \t]*"))) + (split-string (buffer-substring beg end) "\n" t))) + ;; Compute number of columns. If the table contains no + ;; field, create a default table and bail out. + (columns-number + (if fields (apply #'max (mapcar #'length fields)) + (kill-region beg end) + (org-table-create org-table-default-size) + (user-error "Empty table - created default table"))) + (widths nil) + (alignments nil)) + ;; Compute alignment and width for each column. + (dotimes (i columns-number) + (let* ((max-width 1) + (fixed-align? nil) + (numbers 0) + (non-empty 0)) + (dolist (row fields) + (let ((cell (or (nth i row) ""))) + (setq max-width (max max-width (org-string-width cell))) + (cond (fixed-align? nil) + ((equal cell "") nil) + ((string-match "\\`<\\([lrc]\\)[0-9]*>\\'" cell) + (setq fixed-align? (match-string 1 cell))) + (t + (cl-incf non-empty) + (when (string-match-p org-table-number-regexp cell) + (cl-incf numbers)))))) + (push max-width widths) + (push (cond + (fixed-align?) + ((>= numbers (* org-table-number-fraction non-empty)) "r") + (t "l")) + alignments))) + (setq widths (nreverse widths)) + (setq alignments (nreverse alignments)) + ;; Store alignment of this table, for later editing of single + ;; fields. + (setq org-table-last-alignment alignments) + (setq org-table-last-column-widths widths) + ;; Build new table rows. Only replace rows that actually + ;; changed. + (dolist (row fields) + (let ((previous (buffer-substring (point) (line-end-position))) + (new + (format "%s|%s|" + indent + (if (null row) ;horizontal rule + (mapconcat (lambda (w) (make-string (+ 2 w) ?-)) + widths + "+") + (let ((cells ;add missing fields + (append row + (make-list (- columns-number + (length row)) + "")))) + (mapconcat #'identity + (cl-mapcar #'org-table--align-field + cells + widths + alignments) + "|")))))) + (if (equal new previous) + (forward-line) + (insert new "\n") + (delete-region (point) (line-beginning-position 2))))) + (set-marker end nil) + (when org-table-overlay-coordinates (org-table-overlay-coordinates)) + (setq org-table-may-need-update nil)))))) + +;;;###autoload +(defun org-table-justify-field-maybe (&optional new) + "Justify the current field, text to left, number to right. +Optional argument NEW may specify text to replace the current field content." + (cond + ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway + ((org-at-table-hline-p)) + ((and (not new) + (or (not (eq (marker-buffer org-table-aligned-begin-marker) + (current-buffer))) + (< (point) org-table-aligned-begin-marker) + (>= (point) org-table-aligned-end-marker))) + ;; This is not the same table, force a full re-align. + (setq org-table-may-need-update t)) + (t + ;; Realign the current field, based on previous full realign. + (let ((pos (point)) + (col (org-table-current-column))) + (when (> col 0) + (skip-chars-backward "^|") + (if (not (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)")) + (setq org-table-may-need-update t) + (let* ((align (nth (1- col) org-table-last-alignment)) + (width (nth (1- col) org-table-last-column-widths)) + (cell (match-string 0)) + (field (match-string 1)) + (properly-closed? (/= (match-beginning 2) (match-end 2))) + (new-cell + (save-match-data + (cond (org-table-may-need-update + (format " %s |" (or new field))) + ((not properly-closed?) + (setq org-table-may-need-update t) + (format " %s |" (or new field))) + ((not new) + (concat (org-table--align-field field width align) + "|")) + ((<= (org-string-width new) width) + (concat (org-table--align-field new width align) + "|")) + (t + (setq org-table-may-need-update t) + (format " %s |" new)))))) + (unless (equal new-cell cell) + (let (org-table-may-need-update) + (replace-match new-cell t t))) + (goto-char pos)))))))) + +;;;###autoload +(defun org-table-sort-lines + (&optional with-case sorting-type getkey-func compare-func interactive?) + "Sort table lines according to the column at point. + +The position of point indicates the column to be used for +sorting, and the range of lines is the range between the nearest +horizontal separator lines, or the entire table of no such lines +exist. If point is before the first column, you will be prompted +for the sorting column. If there is an active region, the mark +specifies the first line and the sorting column, while point +should be in the last line to be included into the sorting. + +The command then prompts for the sorting type which can be +alphabetically, numerically, or by time (as given in a time stamp +in the field, or as a HH:MM value). Sorting in reverse order is +also possible. + +With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive +if the locale allows for it. + +If SORTING-TYPE is specified when this function is called from a Lisp +program, no prompting will take place. SORTING-TYPE must be a character, +any of (?a ?A ?n ?N ?t ?T ?f ?F) where the capital letters indicate that +sorting should be done in reverse order. + +If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies +a function to be called to extract the key. It must return a value +that is compatible with COMPARE-FUNC, the function used to compare +entries. + +A non-nil value for INTERACTIVE? is used to signal that this +function is being called interactively." + (interactive (list current-prefix-arg nil nil nil t)) + (when (org-region-active-p) (goto-char (region-beginning))) + ;; Point must be either within a field or before a data line. + (save-excursion + (skip-chars-backward " \t") + (when (bolp) (search-forward "|" (line-end-position) t)) + (org-table-check-inside-data-field)) + ;; Set appropriate case sensitivity and column used for sorting. + (let ((column (let ((c (org-table-current-column))) + (cond ((> c 0) c) + (interactive? + (read-number "Use column N for sorting: ")) + (t 1)))) + (sorting-type + (or sorting-type + (read-char-exclusive "Sort Table: [a]lphabetic, [n]umeric, \ +\[t]ime, [f]unc. A/N/T/F means reversed: "))) + (start (org-table-begin)) + (end (org-table-end))) + (save-restriction + ;; Narrow buffer to appropriate sorting area. + (if (org-region-active-p) + (progn (goto-char (region-beginning)) + (narrow-to-region + (point) + (save-excursion (goto-char (region-end)) + (line-beginning-position 2)))) + (narrow-to-region + (save-excursion + (if (re-search-backward org-table-hline-regexp start t) + (line-beginning-position 2) + start)) + (if (save-excursion (re-search-forward org-table-hline-regexp end t)) + (match-beginning 0) + end))) + ;; Determine arguments for `sort-subr'. Also record original + ;; position. `org-table-save-field' cannot help here since + ;; sorting is too much destructive. + (let* ((coordinates + (cons (count-lines (point-min) (line-beginning-position)) + (current-column))) + (extract-key-from-field + ;; Function to be called on the contents of the field + ;; used for sorting in the current row. + (cl-case sorting-type + ((?n ?N) #'string-to-number) + ((?a ?A) #'org-sort-remove-invisible) + ((?t ?T) + (lambda (f) + (cond ((string-match org-ts-regexp-both f) + (float-time + (org-time-string-to-time (match-string 0 f)))) + ((org-duration-p f) (org-duration-to-minutes f)) + ((string-match "\\<[0-9]+:[0-9]\\{2\\}\\>" f) + (org-duration-to-minutes (match-string 0 f))) + (t 0)))) + ((?f ?F) + (or getkey-func + (and interactive? + (org-read-function "Function for extracting keys: ")) + (error "Missing key extractor to sort rows"))) + (t (user-error "Invalid sorting type `%c'" sorting-type)))) + (predicate + (cl-case sorting-type + ((?n ?N ?t ?T) #'<) + ((?a ?A) (if with-case #'org-string-collate-lessp + (lambda (s1 s2) (org-string-collate-lessp s1 s2 nil t)))) + ((?f ?F) + (or compare-func + (and interactive? + (org-read-function + "Function for comparing keys (empty for default \ +`sort-subr' predicate): " + 'allow-empty)))))) + (shrunk-columns (remq column (org-table--list-shrunk-columns)))) + (goto-char (point-min)) + (sort-subr (memq sorting-type '(?A ?N ?T ?F)) + (lambda () + (forward-line) + (while (and (not (eobp)) + (not (looking-at org-table-dataline-regexp))) + (forward-line))) + #'end-of-line + (lambda () + (funcall extract-key-from-field + (org-trim (org-table-get-field column)))) + nil + predicate) + ;; Hide all columns but the one being sorted. + (org-table--shrink-columns shrunk-columns start end) + ;; Move back to initial field. + (forward-line (car coordinates)) + (move-to-column (cdr coordinates)))))) + +(defun org-table-transpose-table-at-point () + "Transpose Org table at point and eliminate hlines. +So a table like + +| 1 | 2 | 4 | 5 | +|---+---+---+---| +| a | b | c | d | +| e | f | g | h | + +will be transposed as + +| 1 | a | e | +| 2 | b | f | +| 4 | c | g | +| 5 | d | h | + +Note that horizontal lines disappear." + (interactive) + (let* ((table (delete 'hline (org-table-to-lisp))) + (dline_old (org-table-current-line)) + (col_old (org-table-current-column)) + (contents (mapcar (lambda (_) + (let ((tp table)) + (mapcar + (lambda (_) + (prog1 + (pop (car tp)) + (setq tp (cdr tp)))) + table))) + (car table)))) + (goto-char (org-table-begin)) + (re-search-forward "|") + (backward-char) + (delete-region (point) (org-table-end)) + (insert (mapconcat + (lambda(x) + (concat "| " (mapconcat 'identity x " | " ) " |\n" )) + contents "")) + (org-table-goto-line col_old) + (org-table-goto-column dline_old)) + (org-table-align)) + +;;;###autoload +(defun org-table-wrap-region (arg) + "Wrap several fields in a column like a paragraph. +This is useful if you'd like to spread the contents of a field over several +lines, in order to keep the table compact. + +If there is an active region, and both point and mark are in the same column, +the text in the column is wrapped to minimum width for the given number of +lines. Generally, this makes the table more compact. A prefix ARG may be +used to change the number of desired lines. For example, \ +`C-2 \\[org-table-wrap-region]' +formats the selected text to two lines. If the region was longer than two +lines, the remaining lines remain empty. A negative prefix argument reduces +the current number of lines by that amount. The wrapped text is pasted back +into the table. If you formatted it to more lines than it was before, fields +further down in the table get overwritten - so you might need to make space in +the table first. + +If there is no region, the current field is split at the cursor position and +the text fragment to the right of the cursor is prepended to the field one +line down. + +If there is no region, but you specify a prefix ARG, the current field gets +blank, and the content is appended to the field above." + (interactive "P") + (org-table-check-inside-data-field) + (if (org-region-active-p) + ;; There is a region: fill as a paragraph. + (let ((start (region-beginning))) + (org-table-cut-region (region-beginning) (region-end)) + (when (> (length (car org-table-clip)) 1) + (user-error "Region must be limited to single column")) + (let ((nlines (cond ((not arg) (length org-table-clip)) + ((< arg 1) (+ (length org-table-clip) arg)) + (t arg)))) + (setq org-table-clip + (mapcar #'list + (org-wrap (mapconcat #'car org-table-clip " ") + nil + nlines)))) + (goto-char start) + (org-table-paste-rectangle)) + ;; No region, split the current field at point. + (unless (org-get-alist-option org-M-RET-may-split-line 'table) + (skip-chars-forward "^\r\n|")) + (cond + (arg ; Combine with field above. + (let ((s (org-table-blank-field)) + (col (org-table-current-column))) + (forward-line -1) + (while (org-at-table-hline-p) (forward-line -1)) + (org-table-goto-column col) + (skip-chars-forward "^|") + (skip-chars-backward " ") + (insert " " (org-trim s)) + (org-table-align))) + ((looking-at "\\([^|]+\\)+|") ; Split field. + (let ((s (match-string 1))) + (replace-match " |") + (goto-char (match-beginning 0)) + (org-table-next-row) + (insert (org-trim s) " ") + (org-table-align))) + (t (org-table-next-row))))) + +(defun org-table--number-for-summing (s) + (let (n) + (if (string-match "^ *|? *" s) + (setq s (replace-match "" nil nil s))) + (if (string-match " *|? *$" s) + (setq s (replace-match "" nil nil s))) + (setq n (string-to-number s)) + (cond + ((and (string-match "0" s) + (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) + ((string-match "\\`[ \t]+\\'" s) nil) + ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) + (let ((h (string-to-number (or (match-string 1 s) "0"))) + (m (string-to-number (or (match-string 2 s) "0"))) + (s (string-to-number (or (match-string 4 s) "0")))) + (if (boundp 'org-timecnt) (setq org-timecnt (1+ org-timecnt))) + (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) + ((equal n 0) nil) + (t n)))) + +;;;###autoload +(defun org-table-sum (&optional beg end nlast) + "Sum numbers in region of current table column. +The result will be displayed in the echo area, and will be available +as kill to be inserted with \\[yank]. + +If there is an active region, it is interpreted as a rectangle and all +numbers in that rectangle will be summed. If there is no active +region and point is located in a table column, sum all numbers in that +column. + +If at least one number looks like a time HH:MM or HH:MM:SS, all other +numbers are assumed to be times as well (in decimal hours) and the +numbers are added as such. + +If NLAST is a number, only the NLAST fields will actually be summed." + (interactive) + (save-excursion + (let (col (org-timecnt 0) diff h m s org-table-clip) + (cond + ((and beg end)) ; beg and end given explicitly + ((org-region-active-p) + (setq beg (region-beginning) end (region-end))) + (t + (setq col (org-table-current-column)) + (goto-char (org-table-begin)) + (unless (re-search-forward "^[ \t]*|[^-]" nil t) + (user-error "No table data")) + (org-table-goto-column col) + (setq beg (point)) + (goto-char (org-table-end)) + (unless (re-search-backward "^[ \t]*|[^-]" nil t) + (user-error "No table data")) + (org-table-goto-column col) + (setq end (point)))) + (let* ((items (apply 'append (org-table-copy-region beg end))) + (items1 (cond ((not nlast) items) + ((>= nlast (length items)) items) + (t (setq items (reverse items)) + (setcdr (nthcdr (1- nlast) items) nil) + (nreverse items)))) + (numbers (delq nil (mapcar #'org-table--number-for-summing + items1))) + (res (apply '+ numbers)) + (sres (if (= org-timecnt 0) + (number-to-string res) + (setq diff (* 3600 res) + h (floor diff 3600) diff (mod diff 3600) + m (floor diff 60) diff (mod diff 60) + s diff) + (format "%.0f:%02.0f:%02.0f" h m s)))) + (kill-new sres) + (when (called-interactively-p 'interactive) + (message (substitute-command-keys + (format "Sum of %d items: %-20s \ +\(\\[yank] will insert result into buffer)" + (length numbers) + sres)))) + sres)))) + +;;;###autoload +(defun org-table-analyze () + "Analyze table at point and store results. + +This function sets up the following dynamically scoped variables: + + `org-table-column-name-regexp', + `org-table-column-names', + `org-table-current-begin-pos', + `org-table-current-line-types', + `org-table-current-ncol', + `org-table-dlines', + `org-table-hlines', + `org-table-local-parameters', + `org-table-named-field-locations'." + (let ((beg (org-table-begin)) + (end (org-table-end))) + (save-excursion + (goto-char beg) + ;; Extract column names. + (setq org-table-column-names nil) + (when (save-excursion + (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t)) + (let ((c 1)) + (dolist (name (org-split-string (match-string 1) " *| *")) + (cl-incf c) + (when (string-match "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" name) + (push (cons name (int-to-string c)) org-table-column-names))))) + (setq org-table-column-names (nreverse org-table-column-names)) + (setq org-table-column-name-regexp + (format "\\$\\(%s\\)\\>" + (regexp-opt (mapcar #'car org-table-column-names) t))) + ;; Extract local parameters. + (setq org-table-local-parameters nil) + (save-excursion + (while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t) + (dolist (field (org-split-string (match-string 1) " *| *")) + (when (string-match + "\\`\\([a-zA-Z][_a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field) + (push (cons (match-string 1 field) (match-string 2 field)) + org-table-local-parameters))))) + ;; Update named fields locations. We minimize `count-lines' + ;; processing by storing last known number of lines in LAST. + (setq org-table-named-field-locations nil) + (save-excursion + (let ((last (cons (point) 0))) + (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) + (let ((c (match-string 1)) + (fields (org-split-string (match-string 2) " *| *"))) + (save-excursion + (forward-line (if (equal c "_") 1 -1)) + (let ((fields1 + (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") + (org-split-string (match-string 1) " *| *"))) + (line (cl-incf (cdr last) (count-lines (car last) (point)))) + (col 1)) + (setcar last (point)) ; Update last known position. + (while (and fields fields1) + (let ((field (pop fields)) + (v (pop fields1))) + (cl-incf col) + (when (and (stringp field) + (stringp v) + (string-match "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" + field)) + (push (cons field v) org-table-local-parameters) + (push (list field line col) + org-table-named-field-locations)))))))))) + ;; Re-use existing markers when possible. + (if (markerp org-table-current-begin-pos) + (move-marker org-table-current-begin-pos (point)) + (setq org-table-current-begin-pos (point-marker))) + ;; Analyze the line types. + (let ((l 0) hlines dlines types) + (while (looking-at "[ \t]*|\\(-\\)?") + (push (if (match-end 1) 'hline 'dline) types) + (if (match-end 1) (push l hlines) (push l dlines)) + (forward-line) + (cl-incf l)) + (push 'hline types) ; Add an imaginary extra hline to the end. + (setq org-table-current-line-types (apply #'vector (nreverse types))) + (setq org-table-dlines (apply #'vector (cons nil (nreverse dlines)))) + (setq org-table-hlines (apply #'vector (cons nil (nreverse hlines))))) + ;; Get the number of columns from the first data line in table. + (goto-char beg) + (forward-line (aref org-table-dlines 1)) + (let* ((fields + (org-split-string + (buffer-substring (line-beginning-position) (line-end-position)) + "[ \t]*|[ \t]*")) + (nfields (length fields)) + al al2) + (setq org-table-current-ncol nfields) + (let ((last-dline + (aref org-table-dlines (1- (length org-table-dlines))))) + (dotimes (i nfields) + (let ((column (1+ i))) + (push (list (format "LR%d" column) last-dline column) al) + (push (cons (format "LR%d" column) (nth i fields)) al2)))) + (setq org-table-named-field-locations + (append org-table-named-field-locations al)) + (setq org-table-local-parameters + (append org-table-local-parameters al2)))))) + +(defun org-table--force-dataline () + "Move point to the closest data line in a table. +Raise an error if the table contains no data line. Preserve +column when moving point." + (unless (org-match-line org-table-dataline-regexp) + (let* ((re org-table-dataline-regexp) + (column (current-column)) + (p1 (save-excursion (re-search-forward re (org-table-end) t))) + (p2 (save-excursion (re-search-backward re (org-table-begin) t)))) + (cond ((and p1 p2) + (goto-char (if (< (abs (- p1 (point))) (abs (- p2 (point)))) + p1 + p2))) + ((or p1 p2) (goto-char (or p1 p2))) + (t (user-error "No table data line around here"))) + (org-move-to-column column)))) (defun org-table-show-reference (&optional local) "Show the location/value of the $ expression at point. @@ -4056,7 +4911,7 @@ When LOCAL is non-nil, show references for the table at point." (org-switch-to-buffer-other-window (get-buffer-window (marker-buffer pos))))) (goto-char pos) - (org-table-force-dataline) + (org-table--force-dataline) (let ((table-start (if local org-table-current-begin-pos (org-table-begin)))) (when dest @@ -4128,158 +4983,8 @@ When LOCAL is non-nil, show references for the table at point." (set-window-start (selected-window) max))))) (select-window win)))) -(defun org-table-force-dataline () - "Make sure the cursor is in a dataline in a table." - (unless (save-excursion - (beginning-of-line 1) - (looking-at org-table-dataline-regexp)) - (let* ((re org-table-dataline-regexp) - (p1 (save-excursion (re-search-forward re nil 'move))) - (p2 (save-excursion (re-search-backward re nil 'move)))) - (cond ((and p1 p2) - (goto-char (if (< (abs (- p1 (point))) (abs (- p2 (point)))) - p1 p2))) - ((or p1 p2) (goto-char (or p1 p2))) - (t (user-error "No table dataline around here")))))) - -(defun org-table-fedit-line-up () - "Move cursor one line up in the window showing the table." - (interactive) - (org-table-fedit-move 'previous-line)) - -(defun org-table-fedit-line-down () - "Move cursor one line down in the window showing the table." - (interactive) - (org-table-fedit-move 'next-line)) - -(defun org-table-fedit-move (command) - "Move the cursor in the window showing the table. -Use COMMAND to do the motion, repeat if necessary to end up in a data line." - (let ((org-table-allow-automatic-line-recalculation nil) - (pos org-pos) (win (selected-window)) p) - (select-window (get-buffer-window (marker-buffer org-pos))) - (setq p (point)) - (call-interactively command) - (while (and (org-at-table-p) - (org-at-table-hline-p)) - (call-interactively command)) - (or (org-at-table-p) (goto-char p)) - (move-marker pos (point)) - (select-window win))) - -(defun org-table-fedit-scroll (N) - (interactive "p") - (let ((other-window-scroll-buffer (marker-buffer org-pos))) - (scroll-other-window N))) - -(defun org-table-fedit-scroll-down (N) - (interactive "p") - (org-table-fedit-scroll (- N))) - -(defvar org-table-rectangle-overlays nil) - -(defun org-table-add-rectangle-overlay (beg end &optional face) - "Add a new overlay." - (let ((ov (make-overlay beg end))) - (overlay-put ov 'face (or face 'secondary-selection)) - (push ov org-table-rectangle-overlays))) - -(defun org-table-highlight-rectangle (&optional beg end face) - "Highlight rectangular region in a table. -When buffer positions BEG and END are provided, use them to -delimit the region to highlight. Otherwise, refer to point. Use -FACE, when non-nil, for the highlight." - (let* ((beg (or beg (point))) - (end (or end (point))) - (b (min beg end)) - (e (max beg end)) - (start-coordinates - (save-excursion - (goto-char b) - (cons (line-beginning-position) (org-table-current-column)))) - (end-coordinates - (save-excursion - (goto-char e) - (cons (line-beginning-position) (org-table-current-column))))) - (when (boundp 'org-show-positions) - (setq org-show-positions (cons b (cons e org-show-positions)))) - (goto-char (car start-coordinates)) - (let ((column-start (min (cdr start-coordinates) (cdr end-coordinates))) - (column-end (max (cdr start-coordinates) (cdr end-coordinates))) - (last-row (car end-coordinates))) - (while (<= (point) last-row) - (when (looking-at org-table-dataline-regexp) - (org-table-goto-column column-start) - (skip-chars-backward "^|\n") - (let ((p (point))) - (org-table-goto-column column-end) - (skip-chars-forward "^|\n") - (org-table-add-rectangle-overlay p (point) face))) - (forward-line))) - (goto-char (car start-coordinates))) - (add-hook 'before-change-functions #'org-table-remove-rectangle-highlight)) - -(defun org-table-remove-rectangle-highlight (&rest _ignore) - "Remove the rectangle overlays." - (unless org-inhibit-highlight-removal - (remove-hook 'before-change-functions 'org-table-remove-rectangle-highlight) - (mapc 'delete-overlay org-table-rectangle-overlays) - (setq org-table-rectangle-overlays nil))) - -(defvar-local org-table-coordinate-overlays nil - "Collects the coordinate grid overlays, so that they can be removed.") - -(defun org-table-overlay-coordinates () - "Add overlays to the table at point, to show row/column coordinates." - (interactive) - (mapc 'delete-overlay org-table-coordinate-overlays) - (setq org-table-coordinate-overlays nil) - (save-excursion - (let ((id 0) (ih 0) hline eol s1 s2 str ic ov beg) - (goto-char (org-table-begin)) - (while (org-at-table-p) - (setq eol (point-at-eol)) - (setq ov (make-overlay (point-at-bol) (1+ (point-at-bol)))) - (push ov org-table-coordinate-overlays) - (setq hline (looking-at org-table-hline-regexp)) - (setq str (if hline (format "I*%-2d" (setq ih (1+ ih))) - (format "%4d" (setq id (1+ id))))) - (org-overlay-before-string ov str 'org-special-keyword 'evaporate) - (when hline - (setq ic 0) - (while (re-search-forward "[+|]\\(-+\\)" eol t) - (setq beg (1+ (match-beginning 0)) - ic (1+ ic) - s1 (concat "$" (int-to-string ic)) - s2 (org-number-to-letters ic) - str (if (eq org-table-use-standard-references t) s2 s1)) - (setq ov (make-overlay beg (+ beg (length str)))) - (push ov org-table-coordinate-overlays) - (org-overlay-display ov str 'org-special-keyword 'evaporate))) - (beginning-of-line 2))))) - -;;;###autoload -(defun org-table-toggle-coordinate-overlays () - "Toggle the display of Row/Column numbers in tables." - (interactive) - (setq org-table-overlay-coordinates (not org-table-overlay-coordinates)) - (message "Tables Row/Column numbers display turned %s" - (if org-table-overlay-coordinates "on" "off")) - (if (and (org-at-table-p) org-table-overlay-coordinates) - (org-table-align)) - (unless org-table-overlay-coordinates - (mapc 'delete-overlay org-table-coordinate-overlays) - (setq org-table-coordinate-overlays nil))) - -;;;###autoload -(defun org-table-toggle-formula-debugger () - "Toggle the formula debugger in tables." - (interactive) - (setq org-table-formula-debug (not org-table-formula-debug)) - (message "Formula debugging has been turned %s" - (if org-table-formula-debug "on" "off"))) - -;;; The orgtbl minor mode + +;;; The Orgtbl minor mode ;; Define a minor mode which can be used in other modes in order to ;; integrate the Org table editor. @@ -4308,7 +5013,6 @@ FACE, when non-nil, for the highlight." ;; active, this binding is ignored inside tables and replaced with a ;; modified self-insert. - (defvar orgtbl-mode-map (make-keymap) "Keymap for `orgtbl-mode'.") @@ -4324,10 +5028,78 @@ FACE, when non-nil, for the highlight." 0 (quote 'org-table) 'prepend)) "Extra `font-lock-keywords' to be added when `orgtbl-mode' is active.") +;;;###autoload +(defun turn-on-orgtbl () + "Unconditionally turn on `orgtbl-mode'." + (require 'org-table) + (orgtbl-mode 1)) + ;; Install it as a minor mode. (put 'orgtbl-mode :included t) (put 'orgtbl-mode :menu-tag "Org Table Mode") +(easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu" + '("OrgTbl" + ["Create or convert" org-table-create-or-convert-from-region + :active (not (org-at-table-p)) :keys "C-c |" ] + "--" + ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"] + ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] + ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] + ["Next Row" org-return :active (org-at-table-p) :keys "RET"] + "--" + ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] + ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] + ["Copy Field from Above" + org-table-copy-down :active (org-at-table-p) :keys "S-RET"] + "--" + ("Column" + ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-<left>"] + ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-<right>"] + ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-<left>"] + ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-<right>"]) + ("Row" + ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-<up>"] + ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"] + ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"] + ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"] + ["Sort lines in region" org-table-sort-lines :active (org-at-table-p) :keys "C-c ^"] + "--" + ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) + ("Rectangle" + ["Copy Rectangle" org-copy-special :active (org-at-table-p)] + ["Cut Rectangle" org-cut-special :active (org-at-table-p)] + ["Paste Rectangle" org-paste-special :active (org-at-table-p)] + ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) + "--" + ("Radio tables" + ["Insert table template" orgtbl-insert-radio-table + (cl-assoc-if #'derived-mode-p orgtbl-radio-table-templates)] + ["Comment/uncomment table" orgtbl-toggle-comment t]) + "--" + ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] + ["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] + ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] + ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] + ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] + ["Iterate all" (org-table-recalculate '(16)) :active (org-at-table-p) :keys "C-u C-u C-c *"] + ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] + ["Sum Column/Rectangle" org-table-sum + :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] + ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] + ["Debug Formulas" + org-table-toggle-formula-debugger :active (org-at-table-p) + :keys "C-c {" + :style toggle :selected org-table-formula-debug] + ["Show Col/Row Numbers" + org-table-toggle-coordinate-overlays :active (org-at-table-p) + :keys "C-c }" + :style toggle :selected org-table-overlay-coordinates] + "--" + ("Plot" + ["Ascii plot" orgtbl-ascii-plot :active (org-at-table-p) :keys "C-c \" a"] + ["Gnuplot" org-plot/gnuplot :active (org-at-table-p) :keys "C-c \" g"]))) + ;;;###autoload (define-minor-mode orgtbl-mode "The Org mode table editor as a minor mode for use in other modes." @@ -4355,15 +5127,12 @@ FACE, when non-nil, for the highlight." (concat orgtbl-line-start-regexp "\\|" auto-fill-inhibit-regexp) orgtbl-line-start-regexp)) - (add-to-invisibility-spec '(org-cwidth)) (when (fboundp 'font-lock-add-keywords) (font-lock-add-keywords nil orgtbl-extra-font-lock-keywords) (org-restart-font-lock)) (easy-menu-add orgtbl-mode-menu)) (t (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp) - (org-table-cleanup-narrow-column-properties) - (org-remove-from-invisibility-spec '(org-cwidth)) (remove-hook 'before-change-functions 'org-before-change-function t) (when (fboundp 'font-lock-remove-keywords) (font-lock-remove-keywords nil orgtbl-extra-font-lock-keywords) @@ -4371,19 +5140,6 @@ FACE, when non-nil, for the highlight." (easy-menu-remove orgtbl-mode-menu) (force-mode-line-update 'all)))) -(defun org-table-cleanup-narrow-column-properties () - "Remove all properties related to narrow-column invisibility." - (let ((s (point-min))) - (while (setq s (text-property-any s (point-max) - 'display org-narrow-column-arrow)) - (remove-text-properties s (1+ s) '(display t))) - (setq s (point-min)) - (while (setq s (text-property-any s (point-max) 'org-cwidth 1)) - (remove-text-properties s (1+ s) '(org-cwidth t))) - (setq s (point-min)) - (while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth)) - (remove-text-properties s (1+ s) '(invisible t))))) - (defun orgtbl-make-binding (fun n &rest keys) "Create a function for binding in the table minor mode. FUN is the command to call inside a table. N is used to create a unique @@ -4498,67 +5254,6 @@ to execute outside of tables." 'delete-char 'org-delete-char 'delete-backward-char 'org-delete-backward-char) (org-defkey orgtbl-mode-map "|" 'org-force-self-insert)) - (easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu" - '("OrgTbl" - ["Create or convert" org-table-create-or-convert-from-region - :active (not (org-at-table-p)) :keys "C-c |" ] - "--" - ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"] - ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] - ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] - ["Next Row" org-return :active (org-at-table-p) :keys "RET"] - "--" - ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] - ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] - ["Copy Field from Above" - org-table-copy-down :active (org-at-table-p) :keys "S-RET"] - "--" - ("Column" - ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-<left>"] - ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-<right>"] - ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-<left>"] - ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-<right>"]) - ("Row" - ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-<up>"] - ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"] - ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"] - ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"] - ["Sort lines in region" org-table-sort-lines :active (org-at-table-p) :keys "C-c ^"] - "--" - ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) - ("Rectangle" - ["Copy Rectangle" org-copy-special :active (org-at-table-p)] - ["Cut Rectangle" org-cut-special :active (org-at-table-p)] - ["Paste Rectangle" org-paste-special :active (org-at-table-p)] - ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) - "--" - ("Radio tables" - ["Insert table template" orgtbl-insert-radio-table - (cl-assoc-if #'derived-mode-p orgtbl-radio-table-templates)] - ["Comment/uncomment table" orgtbl-toggle-comment t]) - "--" - ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] - ["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] - ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] - ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] - ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] - ["Iterate all" (org-table-recalculate '(16)) :active (org-at-table-p) :keys "C-u C-u C-c *"] - ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] - ["Sum Column/Rectangle" org-table-sum - :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] - ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] - ["Debug Formulas" - org-table-toggle-formula-debugger :active (org-at-table-p) - :keys "C-c {" - :style toggle :selected org-table-formula-debug] - ["Show Col/Row Numbers" - org-table-toggle-coordinate-overlays :active (org-at-table-p) - :keys "C-c }" - :style toggle :selected org-table-overlay-coordinates] - "--" - ("Plot" - ["Ascii plot" orgtbl-ascii-plot :active (org-at-table-p) :keys "C-c \" a"] - ["Gnuplot" org-plot/gnuplot :active (org-at-table-p) :keys "C-c \" g"]))) t)) (defun orgtbl-ctrl-c-ctrl-c (arg) @@ -5476,9 +6171,9 @@ list of the fields in the rectangle." org-table-current-line-types org-table-current-begin-pos org-table-dlines org-table-current-ncol - org-table-hlines org-table-last-alignment - org-table-last-column-widths org-table-last-alignment + org-table-hlines org-table-last-column-widths + org-table-last-alignment buffer loc) (setq form (org-table-convert-refs-to-rc form)) (org-with-wide-buffer diff --git a/lisp/org/org-tempo.el b/lisp/org/org-tempo.el new file mode 100644 index 00000000000..78424b28a0e --- /dev/null +++ b/lisp/org/org-tempo.el @@ -0,0 +1,188 @@ +;;; org-tempo.el --- Template expansion for Org structures -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2019 Free Software Foundation, Inc. +;; +;; Author: Rasmus Pank Roulund <emacs at pank dot eu> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;; +;;; Commentary: +;; +;; Org Tempo reimplements completions of structure template before +;; point like `org-try-structure-completion' in Org v9.1 and earlier. +;; For example, strings like "<e" at the beginning of the line will be +;; expanded to an example block. +;; +;; All blocks defined in `org-structure-template-alist' are added as +;; Org Tempo shortcuts, in addition to keywords defined in +;; `org-tempo-keywords-alist'. +;; +;; `tempo' can also be used to define more sophisticated keywords +;; completions. See the section "Additional keywords" below for +;; examples. +;; +;;; Code: + +(require 'tempo) +(require 'cl-lib) +(require 'org) + +(defvar org-structure-template-alist) + + +(defgroup org-tempo nil + "Template expansion of Org structures." + :tag "Org structure" + :group 'org) + +(defvar org-tempo-tags nil + "Tempo tags for Org mode.") + +(defcustom org-tempo-keywords-alist + '(("L" . "latex") + ("H" . "html") + ("A" . "ascii") + ("i" . "index")) + "Keyword completion elements. + +This is an alist of KEY characters and corresponding KEYWORDS, +just like `org-structure-template-alist'. The tempo snippet +\"<KEY\" will be expanded using the KEYWORD value. For example +\"<L\" at the beginning of a line is expanded to \"#+latex:\". + +Do not use \"I\" as a KEY, as it it reserved for expanding +\"#+include\"." + :group 'org-tempo + :type '(repeat (cons (string :tag "Key") + (string :tag "Keyword"))) + :package-version '(Org . "9.2")) + + + +;;; Org Tempo functions and setup. + +(defun org-tempo-setup () + "Setup tempo tags and match finder for the current buffer." + (org-tempo--update-maybe) + (tempo-use-tag-list 'org-tempo-tags) + (setq-local tempo-match-finder "^ *\\(<[[:word:]]+\\)\\=")) + +(defun org-tempo--keys () + "Return a list of all Org Tempo expansion strings, like \"<s\"." + (mapcar (lambda (pair) (format "<%s" (car pair))) + (append org-structure-template-alist + org-tempo-keywords-alist))) + +(defun org-tempo--update-maybe () + "Check and add new Org Tempo templates if necessary. +In particular, if new entries were added to +`org-structure-template-alist' or `org-tempo-keywords-alist', new +Tempo templates will be added." + (unless (cl-every (lambda (key) (assoc key org-tempo-tags)) + (org-tempo--keys)) + (org-tempo-add-templates))) + +(defun org-tempo-add-templates () + "Update all Org Tempo templates. + +Go through `org-structure-template-alist' and +`org-tempo-keywords-alist' and update tempo templates." + (mapc 'org--check-org-structure-template-alist '(org-structure-template-alist + org-tempo-keywords-alist)) + (let ((keys (org-tempo--keys))) + ;; Check for duplicated snippet keys and warn if any are found. + (when (> (length keys) (length (delete-dups keys))) + (warn + "Duplicated keys in `org-structure-template-alist' and `org-tempo-keywords-alist'")) + ;; Remove any keys already defined in case they have been updated. + (setq org-tempo-tags + (cl-remove-if (lambda (tag) (member (car tag) keys)) org-tempo-tags)) + (mapc #'org-tempo-add-block org-structure-template-alist) + (mapc #'org-tempo-add-keyword org-tempo-keywords-alist))) + +(defun org-tempo-add-block (entry) + "Add block entry from `org-structure-template-alist'." + (let* ((key (format "<%s" (car entry))) + (name (cdr entry)) + (special (member name '("src" "export")))) + (tempo-define-template (format "org-%s" (replace-regexp-in-string " " "-" name)) + `(,(format "#+begin_%s%s" name (if special " " "")) + ,(when special 'p) '> n '> ,(unless special 'p) n + ,(format "#+end_%s" (car (split-string name " "))) + >) + key + (format "Insert a %s block" name) + 'org-tempo-tags))) + +(defun org-tempo-add-keyword (entry) + "Add keyword entry from `org-tempo-keywords-alist'." + (let* ((key (format "<%s" (car entry))) + (name (cdr entry))) + (tempo-define-template (format "org-%s" (replace-regexp-in-string " " "-" name)) + `(,(format "#+%s: " name) p '>) + key + (format "Insert a %s keyword" name) + 'org-tempo-tags))) + +(defun org-tempo-complete-tag (&rest _) + "Look for a tag and expand it silently. +Unlike to `tempo-complete-tag', do not give a signal if a partial +completion or no match at all is found. Return nil if expansion +didn't succeed." + (org-tempo--update-maybe) + ;; `tempo-complete-tag' returns its SILENT argument when there is no + ;; completion available at all. + (not (eq 'fail (tempo-complete-tag 'fail)))) + + +;;; Additional keywords + +(defun org-tempo--include-file () + "Add #+include: and a file name." + (let ((inhibit-quit t)) + (unless (with-local-quit + (prog1 t + (insert + (format "#+include: %S " + (file-relative-name + (read-file-name "Include file: ")))))) + (insert "<I") + (setq quit-flag nil)))) + +(tempo-define-template "org-include" + '((org-tempo--include-file) + p >) + "<I" + "Include keyword" + 'org-tempo-tags) + +;;; Setup of Org Tempo +;; +;; Org Tempo is set up with each new Org buffer and potentially in the +;; current Org buffer. + +(add-hook 'org-mode-hook 'org-tempo-setup) +(add-hook 'org-tab-before-tab-emulation-hook 'org-tempo-complete-tag) + +;; Enable Org Tempo in all open Org buffers. +(dolist (b (org-buffer-list 'files)) + (with-current-buffer b (org-tempo-setup))) + +(provide 'org-tempo) + +;;; org-tempo.el ends here diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el index e1bbfa97093..68fe96695c4 100644 --- a/lisp/org/org-timer.el +++ b/lisp/org/org-timer.el @@ -139,7 +139,7 @@ the region 0:00:00." (format "Restart timer with offset [%s]: " def))) (unless (string-match "\\S-" s) (setq s def)) (setq delta (org-timer-hms-to-secs (org-timer-fix-incomplete s))))) - (setq org-timer-start-time (time-since delta))) + (setq org-timer-start-time (org-time-since delta))) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on) (message "Timer start time set to %s, current value is %s" @@ -147,6 +147,7 @@ the region 0:00:00." (org-timer-secs-to-hms (or delta 0))) (run-hooks 'org-timer-start-hook))))) +;;;###autoload (defun org-timer-pause-or-continue (&optional stop) "Pause or continue the relative or countdown timer. With prefix arg STOP, stop it entirely." @@ -162,9 +163,9 @@ With prefix arg STOP, stop it entirely." (setq org-timer-countdown-timer (org-timer--run-countdown-timer new-secs org-timer-countdown-timer-title)) - (setq org-timer-start-time (time-add nil new-secs))) + (setq org-timer-start-time (org-time-add nil new-secs))) (setq org-timer-start-time - (time-since (- pause-secs start-secs)))) + (org-time-since (- pause-secs start-secs)))) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on) (run-hooks 'org-timer-continue-hook) @@ -179,6 +180,7 @@ With prefix arg STOP, stop it entirely." (org-timer-set-mode-line 'paused) (message "Timer paused at %s" (org-timer-value-string))))) +;;;###autoload (defun org-timer-stop () "Stop the relative or countdown timer." (interactive) @@ -217,15 +219,12 @@ it in the buffer." (insert (org-timer-value-string))))) (defun org-timer-value-string () - "Set the timer string." + "Return current timer string." (format org-timer-format (org-timer-secs-to-hms - (abs (floor (org-timer-seconds)))))) - -(defun org-timer-seconds () - (let ((s (float-time (time-subtract org-timer-pause-time - org-timer-start-time)))) - (if org-timer-countdown-timer (- s) s))) + (let ((time (- (float-time org-timer-pause-time) + (float-time org-timer-start-time)))) + (abs (floor (if org-timer-countdown-timer (- time) time))))))) ;;;###autoload (defun org-timer-change-times-in-region (beg end delta) @@ -385,7 +384,10 @@ VALUE can be `on', `off', or `paused'." "No timer set" (format-seconds "%m minute(s) %s seconds left before next time out" - (time-subtract (timer--time org-timer-countdown-timer) nil))))) + ;; Note: Once our minimal require is Emacs 27, we can drop this + ;; org-time-convert-to-integer call. + (org-time-convert-to-integer + (org-time-subtract (timer--time org-timer-countdown-timer) nil)))))) ;;;###autoload (defun org-timer-set-timer (&optional opt) @@ -417,7 +419,9 @@ using three `C-u' prefix arguments." (if (numberp org-timer-default-timer) (number-to-string org-timer-default-timer) org-timer-default-timer)) - (effort-minutes (ignore-errors (floor (org-get-at-eol 'effort-minutes 1)))) + (effort-minutes (let ((effort (org-entry-get nil org-effort-property))) + (when (org-string-nw-p effort) + (floor (org-duration-to-minutes effort))))) (minutes (or (and (numberp opt) (number-to-string opt)) (and (not (equal opt '(64))) effort-minutes @@ -444,7 +448,7 @@ using three `C-u' prefix arguments." (org-timer--run-countdown-timer secs org-timer-countdown-timer-title)) (run-hooks 'org-timer-set-hook) - (setq org-timer-start-time (time-add nil secs)) + (setq org-timer-start-time (org-time-add nil secs)) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on)))))) @@ -462,7 +466,8 @@ time is up." (run-hooks 'org-timer-done-hook))))) (defun org-timer--get-timer-title () - "Construct timer title from heading or file name of Org buffer." + "Construct timer title. +Try to use an Org header, otherwise use the buffer name." (cond ((derived-mode-p 'org-agenda-mode) (let* ((marker (or (get-text-property (point) 'org-marker) @@ -478,7 +483,7 @@ time is up." ((derived-mode-p 'org-mode) (or (ignore-errors (org-get-heading)) (buffer-name (buffer-base-buffer)))) - (t (error "Not in an Org buffer")))) + (t (buffer-name (buffer-base-buffer))))) (provide 'org-timer) diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index 132ad2b3035..2a783871405 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -5,13 +5,13 @@ (defun org-release () "The release version of Org. Inserted by installing Org mode or when a release is made." - (let ((org-release "9.1.9")) + (let ((org-release "9.3")) org-release)) ;;;###autoload (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.1.9-65-g5e4542")) + (let ((org-git-version "release_9.3")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/org.el b/lisp/org/org.el index 73848a46342..b37beeb96a6 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -6,7 +6,7 @@ ;; Author: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: https://orgmode.org -;; Version: 9.1.9 +;; Version: 9.3 ;; ;; This file is part of GNU Emacs. ;; @@ -64,8 +64,7 @@ ;;; Code: (defvar org-inhibit-highlight-removal nil) ; dynamically scoped param -(defvar-local org-table-formula-constants-local nil - "Local version of `org-table-formula-constants'.") +(defvar org-inlinetask-min-level) ;;;; Require other packages @@ -88,16 +87,14 @@ (message "You need to run \"make\" or \"make autoloads\" from Org lisp directory") (sit-for 3)))) -(require 'org-macs) +(eval-and-compile (require 'org-macs)) (require 'org-compat) +(require 'org-keys) +(require 'ol) +(require 'org-table) ;; `org-outline-regexp' ought to be a defconst but is let-bound in ;; some places -- e.g. see the macro `org-with-limited-levels'. -;; -;; In Org buffers, the value of `outline-regexp' is that of -;; `org-outline-regexp'. The only function still directly relying on -;; `outline-regexp' is `org-overview' so that `org-cycle' can do its -;; job when `orgstruct-mode' is active. (defvar org-outline-regexp "\\*+ " "Regexp to match Org headlines.") @@ -112,17 +109,31 @@ Stars are put in group 1 and the trimmed body in group 2.") (declare-function calendar-check-holidays "holidays" (date)) (declare-function cdlatex-environment "ext:cdlatex" (environment item)) +(declare-function cdlatex-math-symbol "ext:cdlatex") +(declare-function Info-goto-node "info" (nodename &optional fork strict-case)) (declare-function isearch-no-upper-case-p "isearch" (string regexp-flag)) (declare-function org-add-archive-files "org-archive" (files)) (declare-function org-agenda-entry-get-agenda-timestamp "org-agenda" (pom)) (declare-function org-agenda-list "org-agenda" (&optional arg start-day span with-hour)) (declare-function org-agenda-redo "org-agenda" (&optional all)) +(declare-function org-agenda-remove-restriction-lock "org-agenda" (&optional noupdate)) +(declare-function org-archive-subtree "org-archive" (&optional find-done)) +(declare-function org-archive-subtree-default "org-archive" ()) +(declare-function org-archive-to-archive-sibling "org-archive" ()) +(declare-function org-attach "org-attach" ()) (declare-function org-babel-do-in-edit-buffer "ob-core" (&rest body) t) (declare-function org-babel-tangle-file "ob-tangle" (file &optional target-file lang)) (declare-function org-beamer-mode "ox-beamer" (&optional prefix) t) +(declare-function org-clock-cancel "org-clock" ()) +(declare-function org-clock-display "org-clock" (&optional arg)) (declare-function org-clock-get-last-clock-out-time "org-clock" ()) +(declare-function org-clock-goto "org-clock" (&optional select)) +(declare-function org-clock-in "org-clock" (&optional select start-time)) +(declare-function org-clock-in-last "org-clock" (&optional arg)) (declare-function org-clock-out "org-clock" (&optional switch-to-state fail-quietly at-time)) +(declare-function org-clock-out-if-current "org-clock" ()) (declare-function org-clock-remove-overlays "org-clock" (&optional beg end noremove)) +(declare-function org-clock-report "org-clock" (&optional arg)) (declare-function org-clock-sum "org-clock" (&optional tstart tend headline-filter propname)) (declare-function org-clock-sum-current-item "org-clock" (&optional tstart)) (declare-function org-clock-timestamps-down "org-clock" (&optional n)) @@ -130,14 +141,15 @@ Stars are put in group 1 and the trimmed body in group 2.") (declare-function org-clock-update-time-maybe "org-clock" ()) (declare-function org-clocking-buffer "org-clock" ()) (declare-function org-clocktable-shift "org-clock" (dir n)) -(declare-function - org-duration-from-minutes "org-duration" (minutes &optional fmt canonical)) +(declare-function org-columns-insert-dblock "org-colview" ()) +(declare-function org-duration-from-minutes "org-duration" (minutes &optional fmt canonical)) (declare-function org-element-at-point "org-element" ()) (declare-function org-element-cache-refresh "org-element" (pos)) (declare-function org-element-cache-reset "org-element" (&optional all)) (declare-function org-element-contents "org-element" (element)) (declare-function org-element-context "org-element" (&optional element)) (declare-function org-element-copy "org-element" (datum)) +(declare-function org-element-create "org-element" (type &optional props &rest children)) (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-link-parser "org-element" ()) @@ -146,60 +158,37 @@ Stars are put in group 1 and the trimmed body in group 2.") (declare-function org-element-property "org-element" (property element)) (declare-function org-element-put-property "org-element" (element property value)) (declare-function org-element-swap-A-B "org-element" (elem-a elem-b)) +(declare-function org-element-timestamp-parser "org-element" ()) (declare-function org-element-type "org-element" (element)) -(declare-function org-element-update-syntax "org-element" ()) +(declare-function org-export-dispatch "ox" (&optional arg)) +(declare-function org-export-get-backend "ox" (name)) +(declare-function org-export-get-environment "ox" (&optional backend subtreep ext-plist)) +(declare-function org-feed-goto-inbox "org-feed" (feed)) +(declare-function org-feed-update-all "org-feed" ()) +(declare-function org-goto "org-goto" (&optional alternative-interface)) (declare-function org-id-find-id-file "org-id" (id)) (declare-function org-id-get-create "org-id" (&optional force)) (declare-function org-inlinetask-at-task-p "org-inlinetask" ()) (declare-function org-inlinetask-outline-regexp "org-inlinetask" ()) (declare-function org-inlinetask-toggle-visibility "org-inlinetask" ()) +(declare-function org-latex-make-preamble "ox-latex" (info &optional template snippet?)) (declare-function org-plot/gnuplot "org-plot" (&optional params)) -(declare-function org-table-align "org-table" ()) -(declare-function org-table-begin "org-table" (&optional table-type)) -(declare-function org-table-beginning-of-field "org-table" (&optional n)) -(declare-function org-table-blank-field "org-table" ()) -(declare-function org-table-calc-current-TBLFM "org-table" (&optional arg)) -(declare-function org-table-copy-region "org-table" (beg end &optional cut)) -(declare-function org-table-cut-region "org-table" (beg end)) -(declare-function org-table-edit-field "org-table" (arg)) -(declare-function org-table-end "org-table" (&optional table-type)) -(declare-function org-table-end-of-field "org-table" (&optional n)) -(declare-function org-table-insert-row "org-table" (&optional arg)) -(declare-function org-table-justify-field-maybe "org-table" (&optional new)) -(declare-function org-table-maybe-eval-formula "org-table" ()) -(declare-function org-table-maybe-recalculate-line "org-table" ()) -(declare-function org-table-next-row "org-table" ()) -(declare-function org-table-paste-rectangle "org-table" ()) -(declare-function org-table-recalculate "org-table" (&optional all noalign)) -(declare-function - org-table-sort-lines "org-table" - (&optional with-case sorting-type getkey-func compare-func interactive?)) -(declare-function org-table-wrap-region "org-table" (arg)) (declare-function org-tags-view "org-agenda" (&optional todo-only match)) -(declare-function orgtbl-ascii-plot "org-table" (&optional ask)) -(declare-function orgtbl-mode "org-table" (&optional arg)) -(declare-function org-export-get-backend "ox" (name)) -(declare-function org-export-get-environment "ox" (&optional backend subtreep ext-plist)) -(declare-function org-latex-make-preamble "ox-latex" (info &optional template snippet?)) +(declare-function org-timer "org-timer" (&optional restart no-insert)) +(declare-function org-timer-item "org-timer" (&optional arg)) +(declare-function org-timer-pause-or-continue "org-timer" (&optional stop)) +(declare-function org-timer-set-timer "org-timer" (&optional opt)) +(declare-function org-timer-start "org-timer" (&optional offset)) +(declare-function org-timer-stop "org-timer" ()) +(declare-function org-toggle-archive-tag "org-archive" (&optional find-done)) +(declare-function org-update-radio-target-regexp "ol" ()) (defvar ffap-url-regexp) (defvar org-element-paragraph-separate) - -(defsubst org-uniquify (list) - "Non-destructively remove duplicate elements from LIST." - (let ((res (copy-sequence list))) (delete-dups res))) - -(defsubst org-get-at-bol (property) - "Get text property PROPERTY at the beginning of line." - (get-text-property (point-at-bol) property)) - -(defsubst org-trim (s &optional keep-lead) - "Remove whitespace at the beginning and the end of string S. -When optional argument KEEP-LEAD is non-nil, removing blank lines -at the beginning of the string does not affect leading indentation." - (replace-regexp-in-string - (if keep-lead "\\`\\([ \t]*\n\\)+" "\\`[ \t\n\r]+") "" - (replace-regexp-in-string "[ \t\n\r]+\\'" "" s))) +(defvar org-indent-indentation-per-level) +(defvar org-radio-target-regexp) +(defvar org-target-link-regexp) +(defvar org-target-regexp) ;; load languages based on value of `org-babel-load-languages' (defvar org-babel-load-languages) @@ -212,53 +201,48 @@ at the beginning of the string does not affect leading indentation." (let ((active (cdr pair)) (lang (symbol-name (car pair)))) (if active (require (intern (concat "ob-" lang))) - (funcall 'fmakunbound - (intern (concat "org-babel-execute:" lang))) - (funcall 'fmakunbound - (intern (concat "org-babel-expand-body:" lang))))))) + (fmakunbound + (intern (concat "org-babel-execute:" lang))) + (fmakunbound + (intern (concat "org-babel-expand-body:" lang))))))) + -(declare-function org-babel-tangle-file "ob-tangle" (file &optional target-file lang)) ;;;###autoload (defun org-babel-load-file (file &optional compile) "Load Emacs Lisp source code blocks in the Org FILE. This function exports the source code using `org-babel-tangle' -and then loads the resulting file using `load-file'. With prefix -arg (noninteractively: 2nd arg) COMPILE the tangled Emacs Lisp -file to byte-code before it is loaded." +and then loads the resulting file using `load-file'. With +optional prefix argument COMPILE, the tangled Emacs Lisp file is +byte-compiled before it is loaded." (interactive "fFile to load: \nP") - (let* ((age (lambda (file) - (float-time - (time-since - (file-attribute-modification-time - (or (file-attributes (file-truename file)) - (file-attributes file))))))) - (base-name (file-name-sans-extension file)) - (exported-file (concat base-name ".el"))) - ;; tangle if the Org file is newer than the elisp file - (unless (and (file-exists-p exported-file) - (> (funcall age file) (funcall age exported-file))) - ;; Tangle-file traversal returns reversed list of tangled files - ;; and we want to evaluate the first target. - (setq exported-file - (car (last (org-babel-tangle-file file exported-file "emacs-lisp"))))) - (message "%s %s" - (if compile - (progn (byte-compile-file exported-file 'load) - "Compiled and loaded") - (progn (load-file exported-file) "Loaded")) - exported-file))) + (let* ((tangled-file (concat (file-name-sans-extension file) ".el"))) + ;; Tangle only if the Org file is newer than the Elisp file. + (unless (org-file-newer-than-p + tangled-file + (file-attribute-modification-time (file-attributes file))) + (org-babel-tangle-file file tangled-file "emacs-lisp")) + (if compile + (progn + (byte-compile-file tangled-file 'load) + (message "Compiled and loaded %s" tangled-file)) + (load-file tangled-file) + (message "Loaded %s" tangled-file)))) (defcustom org-babel-load-languages '((emacs-lisp . t)) "Languages which can be evaluated in Org buffers. +\\<org-mode-map> This list can be used to load support for any of the languages -below, note that each language will depend on a different set of -system executables and/or Emacs modes. When a language is -\"loaded\", then code blocks in that language can be evaluated -with `org-babel-execute-src-block' bound by default to C-c -C-c (note the `org-babel-no-eval-on-ctrl-c-ctrl-c' variable can -be set to remove code block evaluation from the C-c C-c -keybinding. By default only Emacs Lisp (which has no -requirements) is loaded." +below. Each language will depend on a different set of system +executables and/or Emacs modes. + +When a language is \"loaded\", code blocks in that language can +be evaluated with `org-babel-execute-src-block', which is bound +by default to \\[org-ctrl-c-ctrl-c]. + +The `org-babel-no-eval-on-ctrl-c-ctrl-c' option can be set to +remove code block evaluation from \\[org-ctrl-c-ctrl-c]. By +default, only Emacs Lisp is loaded, since it has no specific +requirement." :group 'org-babel :set 'org-babel-do-load-languages :version "24.1" @@ -537,6 +521,20 @@ but the stars and the body are.") An archived subtree does not open during visibility cycling, and does not contribute to the agenda listings.") +(defconst org-tag-re "[[:alnum:]_@#%]+" + "Regexp matching a single tag.") + +(defconst org-tag-group-re "[ \t]+\\(:\\([[:alnum:]_@#%:]+\\):\\)[ \t]*$" + "Regexp matching the tag group at the end of a line, with leading spaces. +Tags are stored in match group 1. Match group 2 stores the tags +without the enclosing colons.") + +(defconst org-tag-line-re + "^\\*+ \\(?:.*[ \t]\\)?\\(:\\([[:alnum:]_@#%:]+\\):\\)[ \t]*$" + "Regexp matching tags in a headline. +Tags are stored in match group 1. Match group 2 stores the tags +without the enclosing colons.") + (eval-and-compile (defconst org-comment-string "COMMENT" "Entries starting with this keyword will never be exported. @@ -564,30 +562,6 @@ An entry can be toggled between COMMENT and normal with "The property that is being used to keep track of effort estimates. Effort estimates given in this property need to have the format H:MM.") -;;;; Table - -(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" - "Detect an org-type or table-type table.") - -(defconst org-table-line-regexp "^[ \t]*|" - "Detect an org-type table line.") - -(defconst org-table-dataline-regexp "^[ \t]*|[^-]" - "Detect an org-type table line.") - -(defconst org-table-hline-regexp "^[ \t]*|-" - "Detect an org-type table hline.") - -(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" - "Detect a table-type table hline.") - -(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" - "Detect the first line outside a table when searching from within it. -This works for both table types.") - -(defconst org-TBLFM-regexp "^[ \t]*#\\+TBLFM: " - "Detect a #+TBLFM line.") - ;;;; Timestamp (defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)>" @@ -633,7 +607,8 @@ on a string that terminates immediately after the date.") The time stamps may be either active or inactive.") (defconst org-repeat-re - "<[0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9] [^>\n]*?\\([.+]?\\+[0-9]+[hdwmy]\\(/[0-9]+[hdwmy]\\)?\\)" + "<[0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9] [^>\n]*?\ +\\([.+]?\\+[0-9]+[hdwmy]\\(/[0-9]+[hdwmy]\\)?\\)" "Regular expression for specifying repeated events. After a match, group 1 contains the repeat expression.") @@ -684,7 +659,7 @@ After a match, group 1 contains the repeat expression.") (org-load-modules-maybe 'force) (org-element-cache-reset 'all))) -(defcustom org-modules '(org-w3m org-bbdb org-bibtex org-docview org-gnus org-info org-irc org-mhe org-rmail) +(defcustom org-modules '(ol-w3m ol-bbdb ol-bibtex ol-docview ol-gnus ol-info ol-irc ol-mhe ol-rmail ol-eww) "Modules that should always be loaded together with org.el. If a description starts with <C>, the file is not part of Emacs @@ -701,63 +676,63 @@ to add the symbol `xyz', and the package must have a call to: For export specific modules, see also `org-export-backends'." :group 'org :set 'org-set-modules - :version "24.4" - :package-version '(Org . "8.0") + :version "26.1" + :package-version '(Org . "9.2") :type '(set :greedy t - (const :tag " bbdb: Links to BBDB entries" org-bbdb) - (const :tag " bibtex: Links to BibTeX entries" org-bibtex) + (const :tag " bbdb: Links to BBDB entries" ol-bbdb) + (const :tag " bibtex: Links to BibTeX entries" ol-bibtex) (const :tag " crypt: Encryption of subtrees" org-crypt) (const :tag " ctags: Access to Emacs tags with links" org-ctags) - (const :tag " docview: Links to doc-view buffers" org-docview) - (const :tag " eww: Store link to url of eww" org-eww) - (const :tag " gnus: Links to GNUS folders/messages" org-gnus) + (const :tag " docview: Links to Docview buffers" ol-docview) + (const :tag " eww: Store link to URL of Eww" ol-eww) + (const :tag " gnus: Links to GNUS folders/messages" ol-gnus) (const :tag " habit: Track your consistency with habits" org-habit) (const :tag " id: Global IDs for identifying entries" org-id) - (const :tag " info: Links to Info nodes" org-info) + (const :tag " info: Links to Info nodes" ol-info) (const :tag " inlinetask: Tasks independent of outline hierarchy" org-inlinetask) - (const :tag " irc: Links to IRC/ERC chat sessions" org-irc) - (const :tag " mhe: Links to MHE folders/messages" org-mhe) + (const :tag " irc: Links to IRC/ERC chat sessions" ol-irc) + (const :tag " mhe: Links to MHE folders/messages" ol-mhe) (const :tag " mouse: Additional mouse support" org-mouse) (const :tag " protocol: Intercept calls from emacsclient" org-protocol) - (const :tag " rmail: Links to RMAIL folders/messages" org-rmail) - (const :tag " w3m: Special cut/paste from w3m to Org mode." org-w3m) + (const :tag " rmail: Links to RMAIL folders/messages" ol-rmail) + (const :tag " tempo: Fast completion for structures" org-tempo) + (const :tag " w3m: Special cut/paste from w3m to Org mode." ol-w3m) + (const :tag " eshell: Links to working directories in Eshell" ol-eshell) - (const :tag "C annotate-file: Annotate a file with org syntax" org-annotate-file) - (const :tag "C bookmark: Org links to bookmarks" org-bookmark) + (const :tag "C annotate-file: Annotate a file with Org syntax" org-annotate-file) + (const :tag "C bookmark: Links to bookmarks" ol-bookmark) (const :tag "C checklist: Extra functions for checklists in repeated tasks" org-checklist) (const :tag "C choose: Use TODO keywords to mark decisions states" org-choose) (const :tag "C collector: Collect properties into tables" org-collector) (const :tag "C depend: TODO dependencies for Org mode\n\t\t\t(PARTIALLY OBSOLETE, see built-in dependency support))" org-depend) - (const :tag "C drill: Flashcards and spaced repetition for Org mode" org-drill) - (const :tag "C elisp-symbol: Org links to emacs-lisp symbols" org-elisp-symbol) - (const :tag "C eshell Support for links to working directories in eshell" org-eshell) + (const :tag "C elisp-symbol: Links to emacs-lisp symbols" ol-elisp-symbol) (const :tag "C eval-light: Evaluate inbuffer-code on demand" org-eval-light) (const :tag "C eval: Include command output as text" org-eval) (const :tag "C expiry: Expiry mechanism for Org entries" org-expiry) - (const :tag "C favtable: Lookup table of favorite references and links" org-favtable) - (const :tag "C git-link: Provide org links to specific file version" org-git-link) + (const :tag "C git-link: Links to specific file version" ol-git-link) (const :tag "C interactive-query: Interactive modification of tags query\n\t\t\t(PARTIALLY OBSOLETE, see secondary filtering)" org-interactive-query) (const :tag "C invoice: Help manage client invoices in Org mode" org-invoice) (const :tag "C learn: SuperMemo's incremental learning algorithm" org-learn) - (const :tag "C mac-iCal Imports events from iCal.app to the Emacs diary" org-mac-iCal) + (const :tag "C mac-iCal: Imports events from iCal.app to the Emacs diary" org-mac-iCal) (const :tag "C mac-link: Grab links and url from various mac Applications" org-mac-link) (const :tag "C mairix: Hook mairix search into Org for different MUAs" org-mairix) - (const :tag "C man: Support for links to manpages in Org mode" org-man) - (const :tag "C mew: Links to Mew folders/messages" org-mew) - (const :tag "C mtags: Support for muse-like tags" org-mtags) - (const :tag "C notmuch: Provide org links to notmuch searches or messages" org-notmuch) + (const :tag "C man: Links to man pages in Org mode" ol-man) + (const :tag "C mew: Links to Mew folders/messages" ol-mew) + (const :tag "C notify: Notifications for Org mode" org-notify) + (const :tag "C notmuch: Provide Org links to notmuch searches or messages" ol-notmuch) (const :tag "C panel: Simple routines for us with bad memory" org-panel) (const :tag "C registry: A registry for Org links" org-registry) - (const :tag "C screen: Visit screen sessions through Org links" org-screen) + (const :tag "C screen: Visit screen sessions through links" org-screen) + (const :tag "C screenshot: Take and manage screenshots in Org files" org-screenshot) (const :tag "C secretary: Team management with Org" org-secretary) (const :tag "C sqlinsert: Convert Org tables to SQL insertions" orgtbl-sqlinsert) (const :tag "C toc: Table of contents for Org buffer" org-toc) (const :tag "C track: Keep up with Org mode development" org-track) (const :tag "C velocity Something like Notational Velocity for Org" org-velocity) - (const :tag "C vm: Links to VM folders/messages" org-vm) + (const :tag "C vm: Links to VM folders/messages" ol-vm) (const :tag "C wikinodes: CamelCase wiki-like links" org-wikinodes) - (const :tag "C wl: Links to Wanderlust folders/messages" org-wl) + (const :tag "C wl: Links to Wanderlust folders/messages" ol-wl) (repeat :tag "External packages" :inline t (symbol :tag "Package")))) (defvar org-export-registered-backends) ; From ox.el. @@ -919,7 +894,8 @@ matching headlines within the active region. Such string must be a tags/property/todo match as it is used in the agenda tags view. The list of commands is: `org-schedule', `org-deadline', -`org-todo', `org-archive-subtree', `org-archive-set-tag' and +`org-todo', `org-set-tags-command', `org-archive-subtree', +`org-archive-set-tag', `org-toggle-archive-tag' and `org-archive-to-archive-sibling'. The archiving commands skip already archived entries." :type '(choice (const :tag "Don't loop" nil) @@ -930,11 +906,6 @@ already archived entries." :group 'org-todo :group 'org-archive) -(defgroup org-startup nil - "Options concerning startup of Org mode." - :tag "Org Startup" - :group 'org) - (defcustom org-startup-folded t "Non-nil means entering Org mode will switch to OVERVIEW. @@ -1029,8 +1000,6 @@ the following lines anywhere in the buffer: (defcustom org-startup-align-all-tables nil "Non-nil means align all tables when visiting a file. -This is useful when the column width in tables is forced with <N> cookies -in table fields. Such tables will look correct only after the first re-align. This can also be configured on a per-file basis by adding one of the following lines anywhere in the buffer: #+STARTUP: align @@ -1038,6 +1007,17 @@ the following lines anywhere in the buffer: :group 'org-startup :type 'boolean) +(defcustom org-startup-shrink-all-tables nil + "Non-nil means shrink all table columns with a width cookie. +This can also be configured on a per-file basis by adding one of +the following lines anywhere in the buffer: + #+STARTUP: shrink" + :group 'org-startup + :type 'boolean + :version "27.1" + :package-version '(Org . "9.2") + :safe #'booleanp) + (defcustom org-startup-with-inline-images nil "Non-nil means show inline images when loading a new Org file. This can also be configured on a per-file basis by adding one of @@ -1070,63 +1050,6 @@ has been set." :group 'org-startup :type 'boolean) -(defvaralias 'org-CUA-compatible 'org-replace-disputed-keys) - -(defcustom org-replace-disputed-keys nil - "Non-nil means use alternative key bindings for some keys. -Org mode uses S-<cursor> keys for changing timestamps and priorities. -These keys are also used by other packages like shift-selection-mode' -\(built into Emacs 23), `CUA-mode' or `windmove.el'. -If you want to use Org mode together with one of these other modes, -or more generally if you would like to move some Org mode commands to -other keys, set this variable and configure the keys with the variable -`org-disputed-keys'. - -This option is only relevant at load-time of Org mode, and must be set -*before* org.el is loaded. Changing it requires a restart of Emacs to -become effective." - :group 'org-startup - :type 'boolean) - -(defcustom org-use-extra-keys nil - "Non-nil means use extra key sequence definitions for certain commands. -This happens automatically if `window-system' is nil. This -variable lets you do the same manually. You must set it before -loading Org." - :group 'org-startup - :type 'boolean) - -(defcustom org-disputed-keys - '(([(shift up)] . [(meta p)]) - ([(shift down)] . [(meta n)]) - ([(shift left)] . [(meta -)]) - ([(shift right)] . [(meta +)]) - ([(control shift right)] . [(meta shift +)]) - ([(control shift left)] . [(meta shift -)])) - "Keys for which Org mode and other modes compete. -This is an alist, cars are the default keys, second element specifies -the alternative to use when `org-replace-disputed-keys' is t. - -Keys can be specified in any syntax supported by `define-key'. -The value of this option takes effect only at Org mode startup, -therefore you'll have to restart Emacs to apply it after changing." - :group 'org-startup - :type 'alist) - -(defun org-key (key) - "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)) - (x (cl-find-if (lambda (x) (equal (key-description (car x)) nkey)) - org-disputed-keys))) - (setq key (if x (cdr x) key)))) - key) - -(defun org-defkey (keymap key def) - "Define a key, possibly translated, as returned by `org-key'." - (define-key keymap (org-key key) def)) - (defcustom org-ellipsis nil "The ellipsis to use in the Org mode outline. @@ -1264,43 +1187,158 @@ new-frame Make a new frame each time. Note that in this case (const :tag "Each time a new frame" new-frame) (const :tag "One dedicated frame" dedicated-frame))) -(defcustom org-use-speed-commands nil - "Non-nil means activate single letter commands at beginning of a headline. -This may also be a function to test for appropriate locations where speed -commands should be active. +(defconst org-file-apps-gnu + '((remote . emacs) + (system . mailcap) + (t . mailcap)) + "Default file applications on a UNIX or GNU/Linux system. +See `org-file-apps'.") + +(defconst org-file-apps-macos + '((remote . emacs) + (system . "open %s") + ("ps.gz" . "gv %s") + ("eps.gz" . "gv %s") + ("dvi" . "xdvi %s") + ("fig" . "xfig %s") + (t . "open %s")) + "Default file applications on a macOS system. +The system \"open\" is known as a default, but we use X11 applications +for some files for which the OS does not have a good default. +See `org-file-apps'.") + +(defconst org-file-apps-windowsnt + (list '(remote . emacs) + (cons 'system (lambda (file _path) + (with-no-warnings (w32-shell-execute "open" file)))) + (cons t (lambda (file _path) + (with-no-warnings (w32-shell-execute "open" file))))) + "Default file applications on a Windows NT system. +The system \"open\" is used for most files. +See `org-file-apps'.") -For example, to activate speed commands when the point is on any -star at the beginning of the headline, you can do this: +(defcustom org-file-apps + '((auto-mode . emacs) + ("\\.mm\\'" . default) + ("\\.x?html?\\'" . default) + ("\\.pdf\\'" . default)) + "External applications for opening `file:path' items in a document. - (setq org-use-speed-commands - (lambda () (and (looking-at org-outline-regexp) (looking-back \"^\\**\"))))" - :group 'org-structure - :type '(choice - (const :tag "Never" nil) - (const :tag "At beginning of headline stars" t) - (function))) +\\<org-mode-map> +Org mode uses system defaults for different file types, but +you can use this variable to set the application for a given file +extension. The entries in this list are cons cells where the car identifies +files and the cdr the corresponding command. -(defcustom org-speed-commands-user nil - "Alist of additional speed commands. -This list will be checked before `org-speed-commands-default' -when the variable `org-use-speed-commands' is non-nil -and when the cursor is at the beginning of a headline. -The car of each entry is a string with a single letter, which must -be assigned to `self-insert-command' in the global map. -The cdr is either a command to be called interactively, a function -to be called, or a form to be evaluated. -An entry that is just a list with a single string will be interpreted -as a descriptive headline that will be added when listing the speed -commands in the Help buffer using the `?' speed command." - :group 'org-structure - :type '(repeat :value ("k" . ignore) - (choice :value ("k" . ignore) - (list :tag "Descriptive Headline" (string :tag "Headline")) - (cons :tag "Letter and Command" - (string :tag "Command letter") - (choice - (function) - (sexp)))))) +Possible values for the file identifier are: + + \"string\" A string as a file identifier can be interpreted in different + ways, depending on its contents: + + - Alphanumeric characters only: + Match links with this file extension. + Example: (\"pdf\" . \"evince %s\") + to open PDFs with evince. + + - Regular expression: Match links where the + filename matches the regexp. If you want to + use groups here, use shy groups. + + Example: (\"\\\\.x?html\\\\\\='\" . \"firefox %s\") + (\"\\\\(?:xhtml\\\\|html\\\\)\\\\\\='\" . \"firefox %s\") + to open *.html and *.xhtml with firefox. + + - Regular expression which contains (non-shy) groups: + Match links where the whole link, including \"::\", and + anything after that, matches the regexp. + In a custom command string, %1, %2, etc. are replaced with + the parts of the link that were matched by the groups. + For backwards compatibility, if a command string is given + that does not use any of the group matches, this case is + handled identically to the second one (i.e. match against + file name only). + In a custom function, you can access the group matches with + (match-string n link). + + Example: (\"\\\\.pdf::\\\\([0-9]+\\\\)\\\\\\='\" . \ +\"evince -p %1 %s\") + to open [[file:document.pdf::5]] with evince at page 5. + + `directory' Matches a directory + `remote' Matches a remote file, accessible through tramp or efs. + Remote files most likely should be visited through Emacs + because external applications cannot handle such paths. +`auto-mode' Matches files that are matched by any entry in `auto-mode-alist', + so all files Emacs knows how to handle. Using this with + command `emacs' will open most files in Emacs. Beware that this + will also open html files inside Emacs, unless you add + (\"html\" . default) to the list as well. + `system' The system command to open files, like `open' on Windows + and macOS, and mailcap under GNU/Linux. This is the command + that will be selected if you call `org-open-at-point' with a + double prefix argument (`\\[universal-argument] \ +\\[universal-argument] \\[org-open-at-point]'). + t Default for files not matched by any of the other options. + +Possible values for the command are: + + `emacs' The file will be visited by the current Emacs process. + `default' Use the default application for this file type, which is the + association for t in the list, most likely in the system-specific + part. This can be used to overrule an unwanted setting in the + system-specific variable. + `system' Use the system command for opening files, like \"open\". + This command is specified by the entry whose car is `system'. + Most likely, the system-specific version of this variable + does define this command, but you can overrule/replace it + here. +`mailcap' Use command specified in the mailcaps. + string A command to be executed by a shell; %s will be replaced + by the path to the file. + function A Lisp function, which will be called with two arguments: + the file path and the original link string, without the + \"file:\" prefix. + +For more examples, see the system specific constants +`org-file-apps-macos' +`org-file-apps-windowsnt' +`org-file-apps-gnu'." + :group 'org + :type '(repeat + (cons (choice :value "" + (string :tag "Extension") + (const :tag "System command to open files" system) + (const :tag "Default for unrecognized files" t) + (const :tag "Remote file" remote) + (const :tag "Links to a directory" directory) + (const :tag "Any files that have Emacs modes" + auto-mode)) + (choice :value "" + (const :tag "Visit with Emacs" emacs) + (const :tag "Use default" default) + (const :tag "Use the system command" system) + (string :tag "Command") + (function :tag "Function"))))) + +(defcustom org-open-non-existing-files nil + "Non-nil means `org-open-file' opens non-existing files. + +When nil, an error is thrown. + +This variable applies only to external applications because they +might choke on non-existing files. If the link is to a file that +will be opened in Emacs, the variable is ignored." + :group 'org + :type 'boolean + :safe #'booleanp) + +(defcustom org-open-directory-means-index-dot-org nil + "When non-nil a link to a directory really means to \"index.org\". +When nil, following a directory link runs Dired or opens +a finder/explorer window on that directory." + :group 'org + :type 'boolean + :safe #'booleanp) (defcustom org-bookmark-names-plist '(:last-capture "org-capture-last-stored" @@ -1428,7 +1466,6 @@ the values `folded', `children', or `subtree'." :type 'hook) (defcustom org-cycle-hook '(org-cycle-hide-archived-subtrees - org-cycle-hide-drawers org-cycle-show-empty-lines org-optimize-window-after-visibility-change) "Hook that is run after `org-cycle' has changed the buffer visibility. @@ -1483,11 +1520,12 @@ stars). The following issues are influenced by this variable: a headline will be indented when this variable is set. Note that this is all about true indentation, by adding and -removing space characters. See also `org-indent.el' which does +removing space characters. See also \"org-indent.el\" which does level-dependent indentation in a virtual way, i.e. at display time in Emacs." :group 'org-edit-structure - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e) @@ -1658,26 +1696,6 @@ make an intelligent decision whether to insert a blank line or not." :group 'org-edit-structure :type 'hook) -(defcustom org-enable-fixed-width-editor t - "Non-nil means lines starting with \":\" are treated as fixed-width. -This currently only means they are never auto-wrapped. -When nil, such lines will be treated like ordinary lines." - :group 'org-edit-structure - :type 'boolean) - -(defcustom org-goto-auto-isearch t - "Non-nil means typing characters in `org-goto' starts incremental search. -When nil, you can use these keybindings to navigate the buffer: - - q Quit the org-goto interface - n Go to the next visible heading - p Go to the previous visible heading - f Go one heading forward on same level - b Go one heading backward on same level - u Go one heading up" - :group 'org-edit-structure - :type 'boolean) - (defgroup org-sparse-trees nil "Options concerning sparse trees in Org mode." :tag "Org Sparse Trees" @@ -1696,8 +1714,8 @@ changed by an edit command." Such highlights are created by `org-occur' and `org-clock-display'. When nil, `\\[org-ctrl-c-ctrl-c]' needs to be used \ to get rid of the highlights. -The highlights created by `org-toggle-latex-fragment' always need -`\\[org-toggle-latex-fragment]' to be removed." +The highlights created by `org-latex-preview' always need +`\\[org-latex-preview]' to be removed." :group 'org-sparse-trees :group 'org-time :type 'boolean) @@ -1720,22 +1738,6 @@ as possible." :group 'org-sparse-trees :type 'hook) -(defgroup org-imenu-and-speedbar nil - "Options concerning imenu and speedbar in Org mode." - :tag "Org Imenu and Speedbar" - :group 'org-structure) - -(defcustom org-imenu-depth 2 - "The maximum level for Imenu access to Org headlines. -This also applied for speedbar access." - :group 'org-imenu-and-speedbar - :type 'integer) - -(defgroup org-table nil - "Options concerning tables in Org mode." - :tag "Org Table" - :group 'org) - (defcustom org-self-insert-cluster-for-undo nil "Non-nil means cluster self-insert commands for undo when possible. If this is set, then, like in the Emacs command loop, 20 consecutive @@ -1744,155 +1746,6 @@ This is configurable, because there is some impact on typing performance." :group 'org-table :type 'boolean) -(defcustom org-table-tab-recognizes-table.el t - "Non-nil means TAB will automatically notice a table.el table. -When it sees such a table, it moves point into it and - if necessary - -calls `table-recognize-table'." - :group 'org-table-editing - :type 'boolean) - -(defgroup org-link nil - "Options concerning links in Org mode." - :tag "Org Link" - :group 'org) - -(defvar-local org-link-abbrev-alist-local nil - "Buffer-local version of `org-link-abbrev-alist', which see. -The value of this is taken from the #+LINK lines.") - -(defcustom org-link-parameters - '(("doi" :follow org--open-doi-link) - ("elisp" :follow org--open-elisp-link) - ("file" :complete org-file-complete-link) - ("ftp" :follow (lambda (path) (browse-url (concat "ftp:" path)))) - ("help" :follow org--open-help-link) - ("http" :follow (lambda (path) (browse-url (concat "http:" path)))) - ("https" :follow (lambda (path) (browse-url (concat "https:" path)))) - ("mailto" :follow (lambda (path) (browse-url (concat "mailto:" path)))) - ("news" :follow (lambda (path) (browse-url (concat "news:" path)))) - ("shell" :follow org--open-shell-link)) - "An alist of properties that defines all the links in Org mode. -The key in each association is a string of the link type. -Subsequent optional elements make up a p-list of link properties. - -:follow - A function that takes the link path as an argument. - -:export - A function that takes the link path, description and -export-backend as arguments. - -:store - A function responsible for storing the link. See the -function `org-store-link-functions'. - -:complete - A function that inserts a link with completion. The -function takes one optional prefix arg. - -:face - A face for the link, or a function that returns a face. -The function takes one argument which is the link path. The -default face is `org-link'. - -:mouse-face - The mouse-face. The default is `highlight'. - -:display - `full' will not fold the link in descriptive -display. Default is `org-link'. - -:help-echo - A string or function that takes (window object position) -as arguments and returns a string. - -:keymap - A keymap that is active on the link. The default is -`org-mouse-map'. - -:htmlize-link - A function for the htmlize-link. Defaults -to (list :uri \"type:path\") - -:activate-func - A function to run at the end of font-lock -activation. The function must accept (link-start link-end path bracketp) -as arguments." - :group 'org-link - :type '(alist :tag "Link display parameters" - :value-type plist) - :version "26.1" - :package-version '(Org . "9.1")) - -(defun org-link-get-parameter (type key) - "Get TYPE link property for KEY. -TYPE is a string and KEY is a plist keyword." - (plist-get - (cdr (assoc type org-link-parameters)) - key)) - -(defun org-link-set-parameters (type &rest parameters) - "Set link TYPE properties to PARAMETERS. - PARAMETERS should be :key val pairs." - (let ((data (assoc type org-link-parameters))) - (if data (setcdr data (org-combine-plists (cdr data) parameters)) - (push (cons type parameters) org-link-parameters) - (org-make-link-regexps) - (org-element-update-syntax)))) - -(defun org-link-types () - "Return a list of known link types." - (mapcar #'car org-link-parameters)) - -(defcustom org-link-abbrev-alist nil - "Alist of link abbreviations. -The car of each element is a string, to be replaced at the start of a link. -The cdrs are replacement values, like (\"linkkey\" . REPLACE). Abbreviated -links in Org buffers can have an optional tag after a double colon, e.g., - - [[linkkey:tag][description]] - -The `linkkey' must be a single word, starting with a letter, followed -by letters, numbers, `-' or `_'. - -If REPLACE is a string, the tag will simply be appended to create the link. -If the string contains \"%s\", the tag will be inserted there. If the string -contains \"%h\", it will cause a url-encoded version of the tag to be inserted -at that point (see the function `url-hexify-string'). If the string contains -the specifier \"%(my-function)\", then the custom function `my-function' will -be invoked: this function takes the tag as its only argument and must return -a string. - -REPLACE may also be a function that will be called with the tag as the -only argument to create the link, which should be returned as a string. - -See the manual for examples." - :group 'org-link - :type '(repeat - (cons - (string :tag "Protocol") - (choice - (string :tag "Format") - (function))))) - -(defcustom org-descriptive-links t - "Non-nil means Org will display descriptive links. -E.g. [[https://orgmode.org][Org website]] will be displayed as -\"Org Website\", hiding the link itself and just displaying its -description. When set to nil, Org will display the full links -literally. - -You can interactively set the value of this variable by calling -`org-toggle-link-display' or from the menu Org>Hyperlinks menu." - :group 'org-link - :type 'boolean) - -(defcustom org-link-file-path-type 'adaptive - "How the path name in file links should be stored. -Valid values are: - -relative Relative to the current directory, i.e. the directory of the file - into which the link is being inserted. -absolute Absolute path, if possible with ~ for home directory. -noabbrev Absolute path, no abbreviation of home directory. -adaptive Use relative path for files in the current directory and sub- - directories of it. For other files, use an absolute path." - :group 'org-link - :type '(choice - (const relative) - (const absolute) - (const noabbrev) - (const adaptive))) - (defvaralias 'org-activate-links 'org-highlight-links) (defcustom org-highlight-links '(bracket angle plain radio tag date footnote) "Types of links that should be highlighted in Org files. @@ -1917,7 +1770,6 @@ footnote Footnote labels. If you set this variable during an Emacs session, use `org-mode-restart' in the Org buffer so that the change takes effect." - :group 'org-link :group 'org-appearance :type '(set :greedy t (const :tag "Double bracket links" bracket) @@ -1928,437 +1780,12 @@ in the Org buffer so that the change takes effect." (const :tag "Timestamps" date) (const :tag "Footnotes" footnote))) -(defcustom org-make-link-description-function nil - "Function to use for generating link descriptions from links. -This function must take two parameters: the first one is the -link, the second one is the description generated by -`org-insert-link'. The function should return the description to -use." - :group 'org-link - :type '(choice (const nil) (function))) - -(defgroup org-link-store nil - "Options concerning storing links in Org mode." - :tag "Org Store Link" - :group 'org-link) - -(defcustom org-url-hexify-p t - "When non-nil, hexify URL when creating a link." - :type 'boolean - :version "24.3" - :group 'org-link-store) - -(defcustom org-email-link-description-format "Email %c: %.30s" - "Format of the description part of a link to an email or usenet message. -The following %-escapes will be replaced by corresponding information: - -%F full \"From\" field -%f name, taken from \"From\" field, address if no name -%T full \"To\" field -%t first name in \"To\" field, address if no name -%c correspondent. Usually \"from NAME\", but if you sent it yourself, it - will be \"to NAME\". See also the variable `org-from-is-user-regexp'. -%s subject -%d date -%m message-id. - -You may use normal field width specification between the % and the letter. -This is for example useful to limit the length of the subject. - -Examples: \"%f on: %.30s\", \"Email from %f\", \"Email %c\"" - :group 'org-link-store - :type 'string) - -(defcustom org-from-is-user-regexp - (let (r1 r2) - (when (and user-mail-address (not (string= user-mail-address ""))) - (setq r1 (concat "\\<" (regexp-quote user-mail-address) "\\>"))) - (when (and user-full-name (not (string= user-full-name ""))) - (setq r2 (concat "\\<" (regexp-quote user-full-name) "\\>"))) - (if (and r1 r2) (concat r1 "\\|" r2) (or r1 r2))) - "Regexp matched against the \"From:\" header of an email or usenet message. -It should match if the message is from the user him/herself." - :group 'org-link-store - :type 'regexp) - -(defcustom org-context-in-file-links t - "Non-nil means file links from `org-store-link' contain context. -\\<org-mode-map> -A search string will be added to the file name with :: as separator -and used to find the context when the link is activated by the command -`org-open-at-point'. When this option is t, the entire active region -will be placed in the search string of the file link. If set to a -positive integer, only the first n lines of context will be stored. - -Using a prefix arg to the command `org-store-link' (`\\[universal-argument] \ -\\[org-store-link]') -negates this setting for the duration of the command." - :group 'org-link-store - :type '(choice boolean integer)) - -(defcustom org-keep-stored-link-after-insertion nil - "Non-nil means keep link in list for entire session. -\\<org-mode-map> -The command `org-store-link' adds a link pointing to the current -location to an internal list. These links accumulate during a session. -The command `org-insert-link' can be used to insert links into any -Org file (offering completion for all stored links). - -When this option is nil, every link which has been inserted once using -`\\[org-insert-link]' will be removed from the list, to make completing the \ -unused -links more efficient." - :group 'org-link-store - :type 'boolean) - -(defgroup org-link-follow nil - "Options concerning following links in Org mode." - :tag "Org Follow Link" - :group 'org-link) - -(defcustom org-link-translation-function nil - "Function to translate links with different syntax to Org syntax. -This can be used to translate links created for example by the Planner -or emacs-wiki packages to Org syntax. -The function must accept two parameters, a TYPE containing the link -protocol name like \"rmail\" or \"gnus\" as a string, and the linked path, -which is everything after the link protocol. It should return a cons -with possibly modified values of type and path. -Org contains a function for this, so if you set this variable to -`org-translate-link-from-planner', you should be able follow many -links created by planner." - :group 'org-link-follow - :type '(choice (const nil) (function))) - -(defcustom org-follow-link-hook nil - "Hook that is run after a link has been followed." - :group 'org-link-follow - :type 'hook) - -(defcustom org-tab-follows-link nil - "Non-nil means on links TAB will follow the link. -Needs to be set before org.el is loaded. -This really should not be used, it does not make sense, and the -implementation is bad." - :group 'org-link-follow - :type 'boolean) - -(defcustom org-return-follows-link nil - "Non-nil means on links RET will follow the link. -In tables, the special behavior of RET has precedence." - :group 'org-link-follow - :type 'boolean) - -(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. -A longer mouse click will still set point. Needs to be set -before org.el is loaded." - :group 'org-link-follow - :version "26.1" - :package-version '(Org . "8.3") - :type '(choice - (const :tag "A double click follows the link" double) - (const :tag "Unconditionally follow the link with mouse-1" t) - (integer :tag "mouse-1 click does not follow the link if longer than N ms" 450))) - (defcustom org-mark-ring-length 4 "Number of different positions to be recorded in the ring. Changing this requires a restart of Emacs to work correctly." :group 'org-link-follow :type 'integer) -(defcustom org-link-search-must-match-exact-headline 'query-to-create - "Non-nil means internal fuzzy links can only match headlines. - -When nil, the a fuzzy link may point to a target or a named -construct in the document. When set to the special value -`query-to-create', offer to create a new headline when none -matched. - -Spaces and statistics cookies are ignored during heading searches." - :group 'org-link-follow - :version "24.1" - :type '(choice - (const :tag "Use fuzzy text search" nil) - (const :tag "Match only exact headline" t) - (const :tag "Match exact headline or query to create it" - query-to-create)) - :safe #'symbolp) - -(defcustom org-link-frame-setup - '((vm . vm-visit-folder-other-frame) - (vm-imap . vm-visit-imap-folder-other-frame) - (gnus . org-gnus-no-new-news) - (file . find-file-other-window) - (wl . wl-other-frame)) - "Setup the frame configuration for following links. -When following a link with Emacs, it may often be useful to display -this link in another window or frame. This variable can be used to -set this up for the different types of links. -For VM, use any of - `vm-visit-folder' - `vm-visit-folder-other-window' - `vm-visit-folder-other-frame' -For Gnus, use any of - `gnus' - `gnus-other-frame' - `org-gnus-no-new-news' -For FILE, use any of - `find-file' - `find-file-other-window' - `find-file-other-frame' -For Wanderlust use any of - `wl' - `wl-other-frame' -For the calendar, use the variable `calendar-setup'. -For BBDB, it is currently only possible to display the matches in -another window." - :group 'org-link-follow - :type '(list - (cons (const vm) - (choice - (const vm-visit-folder) - (const vm-visit-folder-other-window) - (const vm-visit-folder-other-frame))) - (cons (const vm-imap) - (choice - (const vm-visit-imap-folder) - (const vm-visit-imap-folder-other-window) - (const vm-visit-imap-folder-other-frame))) - (cons (const gnus) - (choice - (const gnus) - (const gnus-other-frame) - (const org-gnus-no-new-news))) - (cons (const file) - (choice - (const find-file) - (const find-file-other-window) - (const find-file-other-frame))) - (cons (const wl) - (choice - (const wl) - (const wl-other-frame))))) - -(defcustom org-display-internal-link-with-indirect-buffer nil - "Non-nil means use indirect buffer to display infile links. -Activating internal links (from one location in a file to another location -in the same file) normally just jumps to the location. When the link is -activated with a `\\[universal-argument]' prefix (or with mouse-3), the link \ -is displayed in -another window. When this option is set, the other window actually displays -an indirect buffer clone of the current buffer, to avoid any visibility -changes to the current buffer." - :group 'org-link-follow - :type 'boolean) - -(defcustom org-open-non-existing-files nil - "Non-nil means `org-open-file' will open non-existing files. -When nil, an error will be generated. -This variable applies only to external applications because they -might choke on non-existing files. If the link is to a file that -will be opened in Emacs, the variable is ignored." - :group 'org-link-follow - :type 'boolean) - -(defcustom org-open-directory-means-index-dot-org nil - "Non-nil means a link to a directory really means to index.org. -When nil, following a directory link will run dired or open a finder/explorer -window on that directory." - :group 'org-link-follow - :type 'boolean) - -(defcustom org-confirm-shell-link-function 'yes-or-no-p - "Non-nil means ask for confirmation before executing shell links. -Shell links can be dangerous: just think about a link - - [[shell:rm -rf ~/*][Google Search]] - -This link would show up in your Org document as \"Google Search\", -but really it would remove your entire home directory. -Therefore we advise against setting this variable to nil. -Just change it to `y-or-n-p' if you want to confirm with a -single keystroke rather than having to type \"yes\"." - :group 'org-link-follow - :type '(choice - (const :tag "with yes-or-no (safer)" yes-or-no-p) - (const :tag "with y-or-n (faster)" y-or-n-p) - (const :tag "no confirmation (dangerous)" nil))) -(put 'org-confirm-shell-link-function - 'safe-local-variable - (lambda (x) (member x '(yes-or-no-p y-or-n-p)))) - -(defcustom org-confirm-shell-link-not-regexp "" - "A regexp to skip confirmation for shell links." - :group 'org-link-follow - :version "24.1" - :type 'regexp) - -(defcustom org-confirm-elisp-link-function 'yes-or-no-p - "Non-nil means ask for confirmation before executing Emacs Lisp links. -Elisp links can be dangerous: just think about a link - - [[elisp:(shell-command \"rm -rf ~/*\")][Google Search]] - -This link would show up in your Org document as \"Google Search\", -but really it would remove your entire home directory. -Therefore we advise against setting this variable to nil. -Just change it to `y-or-n-p' if you want to confirm with a -single keystroke rather than having to type \"yes\"." - :group 'org-link-follow - :type '(choice - (const :tag "with yes-or-no (safer)" yes-or-no-p) - (const :tag "with y-or-n (faster)" y-or-n-p) - (const :tag "no confirmation (dangerous)" nil))) -(put 'org-confirm-shell-link-function - 'safe-local-variable - (lambda (x) (member x '(yes-or-no-p y-or-n-p)))) - -(defcustom org-confirm-elisp-link-not-regexp "" - "A regexp to skip confirmation for Elisp links." - :group 'org-link-follow - :version "24.1" - :type 'regexp) - -(defconst org-file-apps-defaults-gnu - '((remote . emacs) - (system . mailcap) - (t . mailcap)) - "Default file applications on a UNIX or GNU/Linux system. -See `org-file-apps'.") - -(defconst org-file-apps-defaults-macosx - '((remote . emacs) - (system . "open %s") - ("ps.gz" . "gv %s") - ("eps.gz" . "gv %s") - ("dvi" . "xdvi %s") - ("fig" . "xfig %s") - (t . "open %s")) - "Default file applications on a macOS system. -The system \"open\" is known as a default, but we use X11 applications -for some files for which the OS does not have a good default. -See `org-file-apps'.") - -(defconst org-file-apps-defaults-windowsnt - (list '(remote . emacs) - (cons 'system (lambda (file _path) - (with-no-warnings (w32-shell-execute "open" file)))) - (cons t (lambda (file _path) - (with-no-warnings (w32-shell-execute "open" file))))) - "Default file applications on a Windows NT system. -The system \"open\" is used for most files. -See `org-file-apps'.") - -(defcustom org-file-apps - '((auto-mode . emacs) - ("\\.mm\\'" . default) - ("\\.x?html?\\'" . default) - ("\\.pdf\\'" . default)) - "External applications for opening `file:path' items in a document. -\\<org-mode-map> -Org mode uses system defaults for different file types, but -you can use this variable to set the application for a given file -extension. The entries in this list are cons cells where the car identifies -files and the cdr the corresponding command. - -Possible values for the file identifier are: - - \"string\" A string as a file identifier can be interpreted in different - ways, depending on its contents: - - - Alphanumeric characters only: - Match links with this file extension. - Example: (\"pdf\" . \"evince %s\") - to open PDFs with evince. - - - Regular expression: Match links where the - filename matches the regexp. If you want to - use groups here, use shy groups. - - Example: (\"\\\\.x?html\\\\\\='\" . \"firefox %s\") - (\"\\\\(?:xhtml\\\\|html\\\\)\\\\\\='\" . \"firefox %s\") - to open *.html and *.xhtml with firefox. - - - Regular expression which contains (non-shy) groups: - Match links where the whole link, including \"::\", and - anything after that, matches the regexp. - In a custom command string, %1, %2, etc. are replaced with - the parts of the link that were matched by the groups. - For backwards compatibility, if a command string is given - that does not use any of the group matches, this case is - handled identically to the second one (i.e. match against - file name only). - In a custom function, you can access the group matches with - (match-string n link). - - Example: (\"\\\\.pdf::\\\\(\\\\d+\\\\)\\\\\\='\" . \ -\"evince -p %1 %s\") - to open [[file:document.pdf::5]] with evince at page 5. - - `directory' Matches a directory - `remote' Matches a remote file, accessible through tramp or efs. - Remote files most likely should be visited through Emacs - because external applications cannot handle such paths. -`auto-mode' Matches files that are matched by any entry in `auto-mode-alist', - so all files Emacs knows how to handle. Using this with - command `emacs' will open most files in Emacs. Beware that this - will also open html files inside Emacs, unless you add - (\"html\" . default) to the list as well. - `system' The system command to open files, like `open' on Windows - and macOS, and mailcap under GNU/Linux. This is the command - that will be selected if you call `org-open-at-point' with a - double prefix argument (`\\[universal-argument] \ -\\[universal-argument] \\[org-open-at-point]'). - t Default for files not matched by any of the other options. - -Possible values for the command are: - - `emacs' The file will be visited by the current Emacs process. - `default' Use the default application for this file type, which is the - association for t in the list, most likely in the system-specific - part. This can be used to overrule an unwanted setting in the - system-specific variable. - `system' Use the system command for opening files, like \"open\". - This command is specified by the entry whose car is `system'. - Most likely, the system-specific version of this variable - does define this command, but you can overrule/replace it - here. -`mailcap' Use command specified in the mailcaps. - string A command to be executed by a shell; %s will be replaced - by the path to the file. - function A Lisp function, which will be called with two arguments: - the file path and the original link string, without the - \"file:\" prefix. - -For more examples, see the system specific constants -`org-file-apps-defaults-macosx' -`org-file-apps-defaults-windowsnt' -`org-file-apps-defaults-gnu'." - :group 'org-link-follow - :type '(repeat - (cons (choice :value "" - (string :tag "Extension") - (const :tag "System command to open files" system) - (const :tag "Default for unrecognized files" t) - (const :tag "Remote file" remote) - (const :tag "Links to a directory" directory) - (const :tag "Any files that have Emacs modes" - auto-mode)) - (choice :value "" - (const :tag "Visit with Emacs" emacs) - (const :tag "Use default" default) - (const :tag "Use the system command" system) - (string :tag "Command") - (function :tag "Function"))))) - -(defcustom org-doi-server-url "https://doi.org/" - "The URL of the DOI server." - :type 'string - :version "24.3" - :group 'org-link-follow) - (defgroup org-refile nil "Options concerning refiling entries in Org mode." :tag "Org Refile" @@ -2388,25 +1815,6 @@ do not specify a target file." :group 'org-capture :type 'file) -(defcustom org-goto-interface 'outline - "The default interface to be used for `org-goto'. -Allowed values are: -outline The interface shows an outline of the relevant file - and the correct heading is found by moving through - the outline or by searching with incremental search. -outline-path-completion Headlines in the current buffer are offered via - completion. This is the interface also used by - the refile command." - :group 'org-refile - :type '(choice - (const :tag "Outline" outline) - (const :tag "Outline-path-completion" outline-path-completion))) - -(defcustom org-goto-max-level 5 - "Maximum target level when running `org-goto' with refile interface." - :group 'org-refile - :type 'integer) - (defcustom org-reverse-note-order nil "Non-nil means store new notes at the beginning of a file or entry. When nil, new notes will be filed to the end of a file or entry. @@ -2438,8 +1846,8 @@ This option can also be set with on a per-file-basis with You can have local logging settings for a subtree by setting the LOGGING property to one or more of these keywords. -When bulk-refiling from the agenda, the value `note' is forbidden and -will temporarily be changed to `time'." +When bulk-refiling, e.g., from the agenda, the value `note' is +forbidden and will temporarily be changed to `time'." :group 'org-refile :group 'org-progress :version "24.1" @@ -2700,31 +2108,35 @@ more information." :type '(choice (const sequence) (const type))) -(defcustom org-use-fast-todo-selection t +(defcustom org-use-fast-todo-selection 'auto "\\<org-mode-map>\ Non-nil means use the fast todo selection scheme with `\\[org-todo]'. This variable describes if and under what circumstances the cycling mechanism for TODO keywords will be replaced by a single-key, direct -selection scheme. +selection scheme, where the choices are displayed in a little window. -When nil, fast selection is never used. +When nil, fast selection is never used. This means that the command +will always switch to the next state. -When the symbol `prefix', it will be used when `org-todo' is called -with a prefix argument, i.e. `\\[universal-argument] \\[org-todo]' \ -in an Org buffer, and -`\\[universal-argument] t' in an agenda buffer. +When it is the symbol `auto', fast selection is whenever selection +keys have been defined. -When t, fast selection is used by default. In this case, the prefix -argument forces cycling instead. +`expert' is like `auto', but no special window with the keyword +will be shown, choices will only be listed in the prompt. In all cases, the special interface is only used if access keys have actually been assigned by the user, i.e. if keywords in the configuration are followed by a letter in parenthesis, like TODO(t)." :group 'org-todo + :set (lambda (var val) + (cond + ((eq var t) (set var 'auto)) + ((eq var 'prefix) (set var nil)) + (t (set var val)))) :type '(choice (const :tag "Never" nil) - (const :tag "By default" t) - (const :tag "Only with C-u C-c C-t" prefix))) + (const :tag "Automatically, when key letter have been defined" auto) + (const :tag "Automatically, but don't show the selection window" expert))) (defcustom org-provide-todo-statistics t "Non-nil means update todo statistics after insert and toggle. @@ -2818,7 +2230,7 @@ When non-nil, you first need to check off all check boxes before the TODO entry can be switched to DONE. This variable needs to be set before org.el is loaded, and you need to restart Emacs after a change to make the change effective. The only way -to change is while Emacs is running is through the customize interface." +to change it while Emacs is running is through the customize interface." :set (lambda (var val) (set var val) (if val @@ -2897,7 +2309,7 @@ property to one or more of these keywords." (setq org-log-done 'note))) (defcustom org-log-reschedule nil - "Information to record when the scheduling date of a tasks is modified. + "Information to record when the scheduling date of a task is modified. Possible values are: @@ -2909,16 +2321,22 @@ This option can also be set with on a per-file-basis with #+STARTUP: nologreschedule #+STARTUP: logreschedule - #+STARTUP: lognotereschedule" + #+STARTUP: lognotereschedule + +You can have local logging settings for a subtree by setting the LOGGING +property to one or more of these keywords. + +This variable has an effect when calling `org-schedule' or +`org-agenda-schedule' only." :group 'org-todo :group 'org-progress :type '(choice (const :tag "No logging" nil) (const :tag "Record timestamp" time) - (const :tag "Record timestamp with note." note))) + (const :tag "Record timestamp with note" note))) (defcustom org-log-redeadline nil - "Information to record when the deadline date of a tasks is modified. + "Information to record when the deadline date of a task is modified. Possible values are: @@ -2933,7 +2351,10 @@ This option can also be set with on a per-file-basis with #+STARTUP: lognoteredeadline You can have local logging settings for a subtree by setting the LOGGING -property to one or more of these keywords." +property to one or more of these keywords. + +This variable has an effect when calling `org-deadline' or +`org-agenda-deadline' only." :group 'org-todo :group 'org-progress :type '(choice @@ -3077,13 +2498,17 @@ This option can also be set with on a per-file-basis with (defcustom org-todo-repeat-to-state nil "The TODO state to which a repeater should return the repeating task. -By default this is the first task in a TODO sequence, or the previous state -in a TODO_TYP set. But you can specify another task here. -alternatively, set the :REPEAT_TO_STATE: property of the entry." +By default this is the first task of a TODO sequence or the +previous state of a TYPE_TODO set. But you can specify to use +the previous state in a TODO sequence or a string. + +Alternatively, you can set the :REPEAT_TO_STATE: property of the +entry, which has precedence over this option." :group 'org-todo :version "24.1" - :type '(choice (const :tag "Head of sequence" nil) - (string :tag "Specific state"))) + :type '(choice (const :tag "Use the previous TODO state" t) + (const :tag "Use the head of the TODO sequence" nil) + (string :tag "Use a specific TODO state"))) (defcustom org-log-repeat 'time "Non-nil means record moving through the DONE state when triggering repeat. @@ -3112,6 +2537,11 @@ property to one or more of these keywords." (const :tag "Force recording the DONE state" time) (const :tag "Force recording a note with the DONE state" note))) +(defcustom org-todo-repeat-hook nil + "Hook that is run after a task has been repeated." + :package-version '(Org . "9.2") + :group 'org-todo + :type 'hook) (defgroup org-priorities nil "Priorities in Org mode." @@ -3311,7 +2741,7 @@ Depending on the system Emacs is running on, certain dates cannot be represented with the type used internally to represent time. Dates between 1970-1-1 and 2038-1-1 can always be represented correctly. Some systems allow for earlier dates, some for later, -some for both. One way to find out it to insert any date into an +some for both. One way to find out is to insert any date into an Org buffer, putting the cursor on the year and hitting S-up and S-down to test the range. @@ -3319,7 +2749,7 @@ When this variable is set to t, the date/time prompt will not let you specify dates outside the 1970-2037 range, so it is certain that these dates will work in whatever version of Emacs you are running, and also that you can move a file from one Emacs implementation -to another. WHenever Org is forcing the year for you, it will display +to another. Whenever Org is forcing the year for you, it will display a message and beep. When this variable is nil, Org will check if the date is @@ -3415,7 +2845,7 @@ The value of this variable is an alist. Associations either: where TAG is a tag as a string, SELECT is character, used to select that tag through the fast tag selection interface, and SPECIAL is one of the following keywords: `:startgroup', -`:startgrouptag', `:grouptags', `:engroup', `:endgrouptag' or +`:startgrouptag', `:grouptags', `:endgroup', `:endgrouptag' or `:newline'. These keywords are used to define a hierarchy of tags. See manual for details. @@ -3452,7 +2882,7 @@ The value of this variable is an alist. Associations either: where TAG is a tag as a string, SELECT is a character, used to select that tag through the fast tag selection interface, and SPECIAL is one of the following keywords: `:startgroup', -`:startgrouptag', `:grouptags', `:engroup', `:endgrouptag' or +`:startgrouptag', `:grouptags', `:endgroup', `:endgrouptag' or `:newline'. These keywords are used to define a hierarchy of tags. See manual for details. @@ -3477,9 +2907,9 @@ on a per-file basis, insert anywhere in the file: (defcustom org-complete-tags-always-offer-all-agenda-tags nil "If non-nil, always offer completion for all tags of all agenda files. -Instead of customizing this variable directly, you might want to -set it locally for capture buffers, because there no list of -tags in that file can be created dynamically (there are none). + +Setting this variable locally allows for dynamic generation of tag +completions in capture buffers. (add-hook \\='org-capture-mode-hook (lambda () @@ -3610,8 +3040,8 @@ is better to limit inheritance to certain tags using the variables :group 'org-tags :type '(choice (const :tag "No sorting" nil) - (const :tag "Alphabetical" string<) - (const :tag "Reverse alphabetical" string>) + (const :tag "Alphabetical" org-string-collate-lessp) + (const :tag "Reverse alphabetical" org-string-collate-greaterp) (function :tag "Custom function" nil))) (defvar org-tags-history nil @@ -3707,6 +3137,18 @@ This variable can be set on the per-file basis by inserting a line :group 'org-properties :type 'string) +(defcustom org-columns-default-format-for-agenda nil + "The default column format in an agenda buffer. +This will be used for column view in the agenda unless a format has +been set by adding `org-overriding-columns-format' to the local +settings list of a custom agenda view. When nil, the columns format +for the first item in the agenda list will be used, or as a fall-back, +`org-columns-default-format'." + :group 'org-properties + :type '(choice + (const :tag "No default" nil) + (string :tag "Format string"))) + (defcustom org-columns-ellipses ".." "The ellipses to be used when a field in column view is truncated. When this is the empty string, as many characters as possible are shown, @@ -3824,25 +3266,6 @@ A nil value means to remove them, after a query, from the list." :group 'org-agenda :type 'boolean) -(defcustom org-calendar-to-agenda-key [?c] - "The key to be installed in `calendar-mode-map' for switching to the agenda. -The command `org-calendar-goto-agenda' will be bound to this key. The -default is the character `c' because then `c' can be used to switch back and -forth between agenda and calendar." - :group 'org-agenda - :type 'sexp) - -(defcustom org-calendar-insert-diary-entry-key [?i] - "The key to be installed in `calendar-mode-map' for adding diary entries. -This option is irrelevant until `org-agenda-diary-file' has been configured -to point to an Org file. When that is the case, the command -`org-agenda-diary-entry' will be bound to the key given here, by default -`i'. In the calendar, `i' normally adds entries to `diary-file'. So -if you want to continue doing this, you need to change this to a different -key." - :group 'org-agenda - :type 'sexp) - (defcustom org-agenda-diary-file 'diary-file "File to which to add new entries with the `i' key in agenda and calendar. When this is the symbol `diary-file', the functionality in the Emacs @@ -3853,17 +3276,6 @@ points to a file, `org-agenda-diary-entry' will be used instead." (const :tag "The standard Emacs diary file" diary-file) (file :tag "Special Org file diary entries"))) -(eval-after-load "calendar" - '(progn - (org-defkey calendar-mode-map org-calendar-to-agenda-key - 'org-calendar-goto-agenda) - (add-hook 'calendar-mode-hook - (lambda () - (unless (eq org-agenda-diary-file 'diary-file) - (define-key calendar-mode-map - org-calendar-insert-diary-entry-key - 'org-agenda-diary-entry)))))) - (defgroup org-latex nil "Options for embedding LaTeX code into Org mode." :tag "Org LaTeX" @@ -3955,12 +3367,11 @@ All available processes and theirs documents can be found in :image-output-type "png" :image-size-adjust (1.0 . 1.0) :latex-compiler ("latex -interaction nonstopmode -output-directory %o %f") - :image-converter ("dvipng -fg %F -bg %B -D %D -T tight -o %O %f")) + :image-converter ("dvipng -D %D -T tight -o %O %f")) (dvisvgm :programs ("latex" "dvisvgm") :description "dvi > svg" :message "you need to install the programs: latex and dvisvgm." - :use-xcolor t :image-input-type "dvi" :image-output-type "svg" :image-size-adjust (1.7 . 1.5) @@ -3970,7 +3381,6 @@ All available processes and theirs documents can be found in :programs ("latex" "convert") :description "pdf > png" :message "you need to install the programs: latex and imagemagick." - :use-xcolor t :image-input-type "pdf" :image-output-type "png" :image-size-adjust (1.0 . 1.0) @@ -3990,11 +3400,6 @@ PROPERTIES accepts the following attributes: :message string, message it when required programs cannot be found. :image-input-type string, input file type of image converter (e.g., \"dvi\"). :image-output-type string, output file type of image converter (e.g., \"png\"). - :use-xcolor boolean, when non-nil, LaTeX \"xcolor\" macro is used to - deal with background and foreground color of image. - Otherwise, dvipng style background and foreground color - format are generated. You may then refer to them in - command options with \"%F\" and \"%B\". :image-size-adjust cons of numbers, the car element is used to adjust LaTeX image size showed in buffer and the cdr element is for HTML file. This option is only useful for process @@ -4026,8 +3431,6 @@ Place-holders used by `:image-converter' and `:latex-compiler': Place-holders only used by `:image-converter': - %F foreground of image - %B background of image %D dpi, which is used to adjust image size by some processing commands. %S the image size scale ratio, which is used to adjust image size by some processing commands." @@ -4151,10 +3554,12 @@ A cell is of the format If SNIPPET-FLAG is non-nil, the package also needs to be included when compiling LaTeX snippets into images for inclusion into -non-LaTeX output. COMPILERS is a list of compilers that should -include the package, see `org-latex-compiler'. If the document -compiler is not in the list, and the list is non-nil, the package -will not be inserted in the final document. +non-LaTeX output. + +COMPILERS is a list of compilers that should include the package, +see `org-latex-compiler'. If the document compiler is not in the +list, and the list is non-nil, the package will not be inserted +in the final document. A string will be inserted as-is in the header of the document." :group 'org-latex @@ -4182,12 +3587,17 @@ Each element is either a cell or a string. A cell is of the format: - (\"options\" \"package\" SNIPPET-FLAG) + (\"options\" \"package\" SNIPPET-FLAG COMPILERS) SNIPPET-FLAG, when non-nil, indicates that this package is also needed when turning LaTeX snippets into images for inclusion into non-LaTeX output. +COMPILERS is a list of compilers that should include the package, +see `org-latex-compiler'. If the document compiler is not in the +list, and the list is non-nil, the package will not be inserted +in the final document. + A string will be inserted as-is in the header of the document. Make sure that you only list packages here which: @@ -4278,10 +3688,18 @@ org-level-* faces." :group 'org-appearance :type 'boolean) +(defcustom org-fontify-whole-block-delimiter-line t + "Non-nil means fontify the whole line for begin/end lines of blocks. +This is useful when setting a background color for the +org-block-begin-line and org-block-end-line faces." + :group 'org-appearance + :type 'boolean) + (defcustom org-highlight-latex-and-related nil "Non-nil means highlight LaTeX related syntax in the buffer. When non-nil, the value should be a list containing any of the following symbols: + `native' Highlight LaTeX snippets and environments natively. `latex' Highlight LaTeX snippets and environments. `script' Highlight subscript and superscript. `entities' Highlight entities." @@ -4291,6 +3709,7 @@ following symbols: :type '(choice (const :tag "No highlighting" nil) (set :greedy t :tag "Highlight" + (const :tag "LaTeX snippets and environments (native)" native) (const :tag "LaTeX snippets and environments" latex) (const :tag "Subscript and superscript" script) (const :tag "Entities" entities)))) @@ -4298,7 +3717,8 @@ following symbols: (defcustom org-hide-emphasis-markers nil "Non-nil mean font-lock should hide the emphasis marker characters." :group 'org-appearance - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defcustom org-hide-macro-markers nil "Non-nil mean font-lock should hide the brackets marking macro calls." @@ -4356,7 +3776,7 @@ After a match, the match groups contain these elements: ;; set this option proved cumbersome. See this message/thread: ;; http://article.gmane.org/gmane.emacs.orgmode/68681 (defvar org-emphasis-regexp-components - '("- \t('\"{" "- \t.,:!?;'\")}\\[" " \t\r\n" "." 1) + '("-[:space:]('\"{" "-[:space:].,:!?;'\")}\\[" "[:space:]" "." 1) "Components used to build the regular expression for emphasis. This is a list with five entries. Terminology: In an emphasis string like \" *strong word* \", we call the initial space PREMATCH, the final @@ -4371,7 +3791,7 @@ body-regexp A regexp like \".\" to match a body character. Don't use non-shy groups here, and don't allow newline here. newline The maximum number of newlines allowed in an emphasis exp. -You need to reload Org or to restart Emacs after customizing this.") +You need to reload Org or to restart Emacs after setting this.") (defcustom org-emphasis-alist '(("*" bold) @@ -4434,23 +3854,22 @@ This is needed for font-lock setup.") "org-agenda" (extra txt &optional level category tags dotime remove-re habitp)) -(declare-function org-agenda-maybe-redo "org-agenda" ()) (declare-function org-agenda-new-marker "org-agenda" (&optional pos)) (declare-function org-agenda-save-markers-for-cut-and-paste "org-agenda" (beg end)) (declare-function org-agenda-set-restriction-lock "org-agenda" (&optional type)) (declare-function org-agenda-skip "org-agenda" ()) -(declare-function org-attach-reveal "org-attach" (&optional if-exists)) +(declare-function org-attach-expand "org-attach" (file)) +(declare-function org-attach-reveal "org-attach" ()) +(declare-function org-attach-reveal-in-emacs "org-attach" ()) (declare-function org-gnus-follow-link "org-gnus" (&optional group article)) (declare-function org-indent-mode "org-indent" (&optional arg)) (declare-function org-inlinetask-goto-beginning "org-inlinetask" ()) (declare-function org-inlinetask-goto-end "org-inlinetask" ()) (declare-function org-inlinetask-in-task-p "org-inlinetask" ()) (declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) -(declare-function orgtbl-send-table "org-table" (&optional maybe)) (declare-function parse-time-string "parse-time" (string)) -(declare-function speedbar-line-directory "speedbar" (&optional depth)) (defvar align-mode-rules-list) (defvar calc-embedded-close-formula) @@ -4462,64 +3881,11 @@ This is needed for font-lock setup.") (defvar remember-data-file) (defvar texmathp-why) -;;;###autoload -(defun turn-on-orgtbl () - "Unconditionally turn on `orgtbl-mode'." - (require 'org-table) - (orgtbl-mode 1)) - -(defun org-at-table-p (&optional table-type) - "Non-nil if the cursor is inside an Org table. -If TABLE-TYPE is non-nil, also check for table.el-type tables." - (and (org-match-line (if table-type "[ \t]*[|+]" "[ \t]*|")) - (or (not (derived-mode-p 'org-mode)) - (let ((e (org-element-lineage (org-element-at-point) '(table) t))) - (and e (or table-type - (eq 'org (org-element-property :type e)))))))) - -(defun org-at-table.el-p () - "Non-nil when point is at a table.el table." - (and (org-match-line "[ \t]*[|+]") - (let ((element (org-element-at-point))) - (and (eq (org-element-type element) 'table) - (eq (org-element-property :type element) 'table.el))))) - -(defun org-at-table-hline-p () - "Non-nil when point is inside a hline in a table. -Assume point is already in a table." - (org-match-line org-table-hline-regexp)) - -(defun org-table-map-tables (function &optional quietly) - "Apply FUNCTION to the start of all tables in the buffer." - (org-with-wide-buffer - (goto-char (point-min)) - (while (re-search-forward org-table-any-line-regexp nil t) - (unless quietly - (message "Mapping tables: %d%%" - (floor (* 100.0 (point)) (buffer-size)))) - (beginning-of-line 1) - (when (and (looking-at org-table-line-regexp) - ;; Exclude tables in src/example/verbatim/clocktable blocks - (not (org-in-block-p '("src" "example" "verbatim" "clocktable")))) - (save-excursion (funcall function)) - (or (looking-at org-table-line-regexp) - (forward-char 1))) - (re-search-forward org-table-any-border-regexp nil 1))) - (unless quietly (message "Mapping tables: done"))) - (declare-function org-clock-save-markers-for-cut-and-paste "org-clock" (beg end)) -(declare-function org-clock-update-mode-line "org-clock" ()) +(declare-function org-clock-update-mode-line "org-clock" (&optional refresh)) (declare-function org-resolve-clocks "org-clock" (&optional also-non-dangling-p prompt last-valid)) -(defun org-at-TBLFM-p (&optional pos) - "Non-nil when point (or POS) is in #+TBLFM line." - (save-excursion - (goto-char (or pos (point))) - (beginning-of-line) - (and (let ((case-fold-search t)) (looking-at org-TBLFM-regexp)) - (eq (org-element-type (org-element-at-point)) 'table)))) - (defvar org-clock-start-time) (defvar org-clock-marker (make-marker) "Marker recording the last clock-in.") @@ -4704,19 +4070,17 @@ STATE should be one of the symbols listed in the docstring of ;; Include headline point is currently on. (beginning-of-line) (while (and (< (point) end) (re-search-forward re end t)) - (when (member org-archive-tag (org-get-tags)) + (when (member org-archive-tag (org-get-tags nil t)) (org-flag-subtree t) (org-end-of-subtree t)))))) -(declare-function outline-end-of-heading "outline" ()) -(declare-function outline-flag-region "outline" (from to flag)) (defun org-flag-subtree (flag) (save-excursion (org-back-to-heading t) - (outline-end-of-heading) - (outline-flag-region (point) - (progn (org-end-of-subtree t) (point)) - flag))) + (org-flag-region (line-end-position) + (progn (org-end-of-subtree t) (point)) + flag + 'outline))) (defalias 'org-advertized-archive-subtree 'org-archive-subtree) @@ -4831,6 +4195,7 @@ After a match, the following groups carry important information: ("oddeven" org-odd-levels-only nil) ("align" org-startup-align-all-tables t) ("noalign" org-startup-align-all-tables nil) + ("shrink" org-startup-shrink-all-tables t) ("inlineimages" org-startup-with-inline-images t) ("noinlineimages" org-startup-with-inline-images nil) ("latexpreview" org-startup-with-latex-preview t) @@ -4903,17 +4268,39 @@ Support for group tags is controlled by the option (message "Groups tags support has been turned %s" (if org-group-tags "on" "off"))) -(defun org-tag-add-to-alist (alist1 alist2) - "Append ALIST1 elements to ALIST2 if they are not there yet." +(defun org--tag-add-to-alist (alist1 alist2) + "Merge tags from ALIST1 into ALIST2. + +Duplicates tags outside a group are removed. Keywords and order +are preserved. + +The function assumes ALIST1 and ALIST2 are proper tag alists. +See `org-tag-alist' for their structure." (cond ((null alist2) alist1) ((null alist1) alist2) - (t (let ((alist2-cars (mapcar (lambda (x) (car-safe x)) alist2)) - to-add) - (dolist (i alist1) - (unless (member (car-safe i) alist2-cars) - (push i to-add))) - (append to-add alist2))))) + (t + (let ((to-add nil) + (group-flag nil)) + (dolist (tag-pair alist1) + (pcase tag-pair + (`(,(or :startgrouptag :startgroup)) + (setq group-flag t) + (push tag-pair to-add)) + (`(,(or :endgrouptag :endgroup)) + (setq group-flag nil) + (push tag-pair to-add)) + (`(,(or :grouptags :newline)) + (push tag-pair to-add)) + (`(,tag . ,_) + ;; Remove duplicates from ALIST1, unless they are in + ;; a group. Indeed, it makes sense to have a tag appear in + ;; multiple groups. + (when (or group-flag (not (assoc tag alist2))) + (push tag-pair to-add))) + (_ (error "Invalid association in tag alist: %S" tag-pair)))) + ;; Preserve order of ALIST1. + (append (nreverse to-add) alist2))))) (defun org-set-regexps-and-options (&optional tags-only) "Precompute regular expressions used in the current buffer. @@ -4943,7 +4330,7 @@ related expressions." (mapcar #'org-add-prop-inherited (cdr (assq 'filetags alist)))) (setq org-current-tag-alist - (org-tag-add-to-alist + (org--tag-add-to-alist org-tag-persistent-alist (let ((tags (cdr (assq 'tags alist)))) (if tags (org-tag-string-to-alist tags) @@ -5167,8 +4554,7 @@ Return value contains the following keys: `archive', `category', ((equal key "SETUPFILE") (unless buffer-read-only ; Do not check in Gnus messages. (let ((f (and (org-string-nw-p value) - (expand-file-name - (org-unbracket-string "\"" "\"" value))))) + (expand-file-name (org-strip-quotes value))))) (when (and f (file-readable-p f) (not (member f files))) (with-temp-buffer (setq default-directory (file-name-directory f)) @@ -5187,8 +4573,7 @@ S is a value for TAGS keyword or produced with `org-tag-alist-to-string'. Return value is an alist suitable for `org-tag-alist' or `org-tag-persistent-alist'." (let ((lines (mapcar #'split-string (split-string s "\n" t))) - (tag-re (concat "\\`\\([[:alnum:]_@#%]+" - "\\|{.+?}\\)" ; regular expression + (tag-re (concat "\\`\\(" org-tag-re "\\|{.+?}\\)" ; regular expression "\\(?:(\\(.\\))\\)?\\'")) alist group-flag) (dolist (tokens lines (cdr (nreverse alist))) @@ -5387,12 +4772,6 @@ This is for getting out of special buffers like capture.") ;;;; Define the Org mode -;; We use a before-change function to check if a table might need -;; an update. -(defvar org-table-may-need-update t - "Indicates that a table might need an update. -This variable is set by `org-before-change-function'. -`org-table-align' sets it back to nil.") (defun org-before-change-function (_beg _end) "Every change indicates that a table might need an update." (setq org-table-may-need-update t)) @@ -5401,7 +4780,6 @@ This variable is set by `org-before-change-function'. (defvar org-agenda-keep-modes nil) ; Dynamically-scoped param. (defvar org-inhibit-logging nil) ; Dynamically-scoped param. (defvar org-inhibit-blocking nil) ; Dynamically-scoped param. -(defvar org-table-buffer-is-an nil) (defvar bidi-paragraph-direction) (defvar buffer-face-mode-face) @@ -5447,20 +4825,11 @@ can be exported as a structured ASCII or HTML file. The following commands are available: \\{org-mode-map}" - - ;; Get rid of Outline menus, they are not needed - ;; Need to do this here because define-derived-mode sets up - ;; the keymap so late. Still, it is a waste to call this each time - ;; we switch another buffer into Org mode. - (define-key org-mode-map [menu-bar headings] 'undefined) - (define-key org-mode-map [menu-bar hide] 'undefined) - (define-key org-mode-map [menu-bar show] 'undefined) - (org-load-modules-maybe) (org-install-agenda-files-menu) - (when org-descriptive-links (add-to-invisibility-spec '(org-link))) - (add-to-invisibility-spec '(org-cwidth)) + (when org-link-descriptive (add-to-invisibility-spec '(org-link))) (add-to-invisibility-spec '(org-hide-block . t)) + (add-to-invisibility-spec '(org-hide-drawer . t)) (setq-local outline-regexp org-outline-regexp) (setq-local outline-level 'org-outline-level) (setq bidi-paragraph-direction 'left-to-right) @@ -5480,10 +4849,11 @@ The following commands are available: ;; Calc embedded (setq-local calc-embedded-open-mode "# ") ;; Modify a few syntax entries - (modify-syntax-entry ?@ "w") (modify-syntax-entry ?\" "\"") (modify-syntax-entry ?\\ "_") (modify-syntax-entry ?~ "_") + (modify-syntax-entry ?< "(>") + (modify-syntax-entry ?> ")<") (setq-local font-lock-unfontify-region-function 'org-unfontify-region) ;; Activate before-change-function (setq-local org-table-may-need-update t) @@ -5513,6 +4883,8 @@ The following commands are available: (forward-char -1)))) ;; Next error for sparse trees (setq-local next-error-function 'org-occur-next-match) + ;; Make commit log messages from Org documents easier. + (setq-local add-log-current-defun-function #'org-add-log-current-headline) ;; Make sure dependence stuff works reliably, even for users who set it ;; too late :-( (if org-enforce-todo-dependencies @@ -5533,9 +4905,6 @@ The following commands are available: (regexp . "^[ \t]*#\\+[A-Z_]+:\\(\\s-*\\)\\S-+") (modes . '(org-mode))))) - ;; Imenu - (setq-local imenu-create-index-function 'org-imenu-get-tree) - ;; Make isearch reveal context (setq-local outline-isearch-open-invisible-function (lambda (&rest _) (org-show-context 'isearch))) @@ -5559,14 +4928,19 @@ The following commands are available: (unless org-inhibit-startup (org-unmodified (when org-startup-with-beamer-mode (org-beamer-mode)) - (when org-startup-align-all-tables - (org-table-map-tables #'org-table-align t)) + (when (or org-startup-align-all-tables org-startup-shrink-all-tables) + (org-table-map-tables + (cond ((and org-startup-align-all-tables + org-startup-shrink-all-tables) + (lambda () (org-table-align) (org-table-shrink))) + (org-startup-align-all-tables #'org-table-align) + (t #'org-table-shrink)) + t)) (when org-startup-with-inline-images (org-display-inline-images)) - (when org-startup-with-latex-preview (org-toggle-latex-fragment '(16))) + (when org-startup-with-latex-preview (org-latex-preview '(16))) (unless org-inhibit-startup-visibility-stuff (org-set-startup-visibility)) (when org-startup-truncated (setq truncate-lines t)) - (when org-startup-indented (require 'org-indent) (org-indent-mode 1)) - (org-refresh-effort-properties))) + (when org-startup-indented (require 'org-indent) (org-indent-mode 1)))) ;; Try to set `org-hide' face correctly. (let ((foreground (org-find-invisible-foreground))) (when foreground @@ -5580,7 +4954,8 @@ The following commands are available: ("8.2.7" . "24.4") ("8.3" . "26.1") ("9.0" . "26.1") - ("9.1" . "26.1"))) + ("9.1" . "26.1") + ("9.2" . "27.1"))) (defvar org-mode-transpose-word-syntax-table (let ((st (make-syntax-table text-mode-syntax-table))) @@ -5618,56 +4993,19 @@ the rounding returns a past time." (let* ((time (decode-time now)) (res (apply #'encode-time 0 (* r (round (nth 1 time) r)) (nthcdr 2 time)))) - (if (or (not past) (time-less-p res now)) + (if (or (not past) (org-time-less-p res now)) res - (time-subtract res (* r 60))))))) + (org-time-subtract res (* r 60))))))) (defun org-today () "Return today date, considering `org-extend-today-until'." (time-to-days - (time-since (* 3600 org-extend-today-until)))) + (org-time-since (* 3600 org-extend-today-until)))) ;;;; Font-Lock stuff, including the activators -(defvar org-mouse-map (make-sparse-keymap)) -(org-defkey org-mouse-map [mouse-2] 'org-open-at-mouse) -(org-defkey org-mouse-map [mouse-3] 'org-find-file-at-mouse) -(when org-mouse-1-follows-link - (org-defkey org-mouse-map [follow-link] 'mouse-face)) -(when org-tab-follows-link - (org-defkey org-mouse-map [(tab)] 'org-open-at-point) - (org-defkey org-mouse-map "\C-i" 'org-open-at-point)) - (require 'font-lock) -(defconst org-non-link-chars "]\t\n\r<>") -(defvar org-link-types-re nil - "Matches a link that has a url-like prefix like \"http:\"") -(defvar org-link-re-with-space nil - "Matches a link with spaces, optional angular brackets around it.") -(defvar org-link-re-with-space2 nil - "Matches a link with spaces, optional angular brackets around it.") -(defvar org-link-re-with-space3 nil - "Matches a link with spaces, only for internal part in bracket links.") -(defvar org-angle-link-re nil - "Matches link with angular brackets, spaces are allowed.") -(defvar org-plain-link-re nil - "Matches plain link, without spaces.") -(defvar org-bracket-link-regexp nil - "Matches a link in double brackets.") -(defvar org-bracket-link-analytic-regexp nil - "Regular expression used to analyze links. -Here is what the match groups contain after a match: -1: http: -2: http -3: path -4: [desc] -5: desc") -(defvar org-bracket-link-analytic-regexp++ nil - "Like `org-bracket-link-analytic-regexp', but include coderef internal type.") -(defvar org-any-link-re nil - "Regular expression matching any link.") - (defconst org-match-sexp-depth 3 "Number of stacked braces for sub/superscript matching.") @@ -5705,59 +5043,6 @@ stacked delimiters is N. Escaping delimiters is not possible." "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)") "The regular expression matching a sub- or superscript, forcing braces.") -(defun org-make-link-regexps () - "Update the link regular expressions. -This should be called after the variable `org-link-parameters' has changed." - (let ((types-re (regexp-opt (org-link-types) t))) - (setq org-link-types-re - (concat "\\`" types-re ":") - org-link-re-with-space - (concat "<?" types-re ":" - "\\([^" org-non-link-chars " ]" - "[^" org-non-link-chars "]*" - "[^" org-non-link-chars " ]\\)>?") - org-link-re-with-space2 - (concat "<?" types-re ":" - "\\([^" org-non-link-chars " ]" - "[^\t\n\r]*" - "[^" org-non-link-chars " ]\\)>?") - org-link-re-with-space3 - (concat "<?" types-re ":" - "\\([^" org-non-link-chars " ]" - "[^\t\n\r]*\\)") - org-angle-link-re - (format "<%s:\\([^>\n]*\\(?:\n[ \t]*[^> \t\n][^>\n]*\\)*\\)>" - types-re) - org-plain-link-re - (concat - "\\<" types-re ":" - "\\([^][ \t\n()<>]+\\(?:([[:word:]0-9_]+)\\|\\([^[:punct:] \t\n]\\|/\\)\\)\\)") - ;; "\\([^]\t\n\r<>() ]+[^]\t\n\r<>,.;() ]\\)") - org-bracket-link-regexp - "\\[\\[\\([^][]+\\)\\]\\(\\[\\([^][]+\\)\\]\\)?\\]" - org-bracket-link-analytic-regexp - (concat - "\\[\\[" - "\\(" types-re ":\\)?" - "\\([^]]+\\)" - "\\]" - "\\(\\[" "\\([^]]+\\)" "\\]\\)?" - "\\]") - org-bracket-link-analytic-regexp++ - (concat - "\\[\\[" - "\\(" (regexp-opt (cons "coderef" (org-link-types)) t) ":\\)?" - "\\([^]]+\\)" - "\\]" - "\\(\\[" "\\([^]]+\\)" "\\]\\)?" - "\\]") - org-any-link-re - (concat "\\(" org-bracket-link-regexp "\\)\\|\\(" - org-angle-link-re "\\)\\|\\(" - org-plain-link-re "\\)")))) - -(org-make-link-regexps) - (defvar org-emph-face nil) (defun org-do-emphasis-faces (limit) @@ -5796,7 +5081,9 @@ This should be called after the variable `org-link-parameters' has changed." (match-beginning 2) (match-end 2) 'face face) (when verbatim? (org-remove-flyspell-overlays-in - (match-beginning 0) (match-end 0))) + (match-beginning 0) (match-end 0)) + (remove-text-properties (match-beginning 2) (match-end 2) + '(display t invisible t intangible t))) (add-text-properties (match-beginning 2) (match-end 2) '(font-lock-multiline t org-emphasis t)) (when org-hide-emphasis-markers @@ -5861,13 +5148,18 @@ prompted for." "Add link properties to links. This includes angle, plain, and bracket links." (catch :exit - (while (re-search-forward org-any-link-re limit t) + (while (re-search-forward org-link-any-re limit t) (let* ((start (match-beginning 0)) (end (match-end 0)) + (visible-start (or (match-beginning 3) (match-beginning 2))) + (visible-end (or (match-end 3) (match-end 2))) (style (cond ((eq ?< (char-after start)) 'angle) ((eq ?\[ (char-after (1+ start))) 'bracket) (t 'plain)))) (when (and (memq style org-highlight-links) + ;; Do not span over paragraph boundaries. + (not (string-match-p org-element-paragraph-separate + (match-string 0))) ;; Do not confuse plain links with tags. (not (and (eq style 'plain) (let ((face (get-text-property @@ -5910,9 +5202,7 @@ This includes angle, plain, and bracket links." (append `(invisible ,(or (org-link-get-parameter type :display) 'org-link)) - properties)) - (visible-start (or (match-beginning 4) (match-beginning 2))) - (visible-end (or (match-end 4) (match-end 2)))) + properties))) (add-text-properties start visible-start hidden) (add-text-properties visible-start visible-end properties) (add-text-properties visible-end end hidden) @@ -5962,57 +5252,64 @@ by a #." "^\\([ \t]*#\\(\\(\\+[a-zA-Z]+:?\\| \\|$\\)\\(_\\([a-zA-Z]+\\)\\)?\\)[ \t]*\\(\\([^ \t\n]*\\)[ \t]*\\(.*\\)\\)\\)" limit t) (let ((beg (match-beginning 0)) - (block-start (match-end 0)) - (block-end nil) - (lang (match-string 7)) - (beg1 (line-beginning-position 2)) + (end-of-beginline (match-end 0)) + (block-start (match-end 0)) ; includes the \n at end of #+begin line + (block-end nil) ; will include \n after end of block content + (lang (match-string 7)) ; the language, if it is an src block + (bol-after-beginline (line-beginning-position 2)) (dc1 (downcase (match-string 2))) (dc3 (downcase (match-string 3))) - end end1 quoting block-type) + (whole-blockline org-fontify-whole-block-delimiter-line) + beg-of-endline end-of-endline nl-before-endline quoting block-type) (cond ((and (match-end 4) (equal dc3 "+begin")) ;; Truly a block (setq block-type (downcase (match-string 5)) - quoting (member block-type org-protecting-blocks)) + quoting (member block-type org-protecting-blocks)) ; src, example, export, maybe more (when (re-search-forward (concat "^[ \t]*#\\+end" (match-string 4) "\\>.*") nil t) ;; on purpose, we look further than LIMIT - (setq end (min (point-max) (match-end 0)) - end1 (min (point-max) (1- (match-beginning 0)))) - (setq block-end (match-beginning 0)) + ;; We do have a matching #+end line + (setq beg-of-endline (match-beginning 0) + end-of-endline (match-end 0) + nl-before-endline (1- (match-beginning 0))) + (setq block-end (match-beginning 0)) ; includes the final newline. (when quoting - (org-remove-flyspell-overlays-in beg1 end1) - (remove-text-properties beg end + (org-remove-flyspell-overlays-in bol-after-beginline nl-before-endline) + (remove-text-properties beg end-of-endline '(display t invisible t intangible t))) (add-text-properties - beg end '(font-lock-fontified t font-lock-multiline t)) - (add-text-properties beg beg1 '(face org-meta-line)) - (org-remove-flyspell-overlays-in beg beg1) - (add-text-properties ; For end_src - end1 (min (point-max) (1+ end)) '(face org-meta-line)) - (org-remove-flyspell-overlays-in end1 end) + beg end-of-endline '(font-lock-fontified t font-lock-multiline t)) + (org-remove-flyspell-overlays-in beg bol-after-beginline) + (org-remove-flyspell-overlays-in nl-before-endline end-of-endline) (cond ((and lang (not (string= lang "")) org-src-fontify-natively) (org-src-font-lock-fontify-block lang block-start block-end) - (add-text-properties beg1 block-end '(src-block t))) + (add-text-properties bol-after-beginline block-end '(src-block t))) (quoting - (add-text-properties beg1 (min (point-max) (1+ end1)) - (list 'face - (list :inherit - (let ((face-name - (intern (format "org-block-%s" lang)))) - (append (and (facep face-name) (list face-name)) - '(org-block))))))) ; end of source block + (add-text-properties + bol-after-beginline beg-of-endline + (list 'face + (list :inherit + (let ((face-name + (intern (format "org-block-%s" lang)))) + (append (and (facep face-name) (list face-name)) + '(org-block))))))) ((not org-fontify-quote-and-verse-blocks)) ((string= block-type "quote") (add-face-text-property - beg1 (min (point-max) (1+ end1)) 'org-quote t)) + bol-after-beginline beg-of-endline 'org-quote t)) ((string= block-type "verse") (add-face-text-property - beg1 (min (point-max) (1+ end1)) 'org-verse t))) - (add-text-properties beg beg1 '(face org-block-begin-line)) - (add-text-properties (min (point-max) (1+ end)) (min (point-max) (1+ end1)) - '(face org-block-end-line)) + bol-after-beginline beg-of-endline 'org-verse t))) + ;; Fontify the #+begin and #+end lines of the blocks + (add-text-properties + beg (if whole-blockline bol-after-beginline end-of-beginline) + '(face org-block-begin-line)) + (add-text-properties + beg-of-endline + (min (point-max) (if whole-blockline (min (point-max) (1+ end-of-endline)) end-of-endline)) + '(face org-block-end-line)) t)) ((member dc1 '("+title:" "+author:" "+email:" "+date:")) (org-remove-flyspell-overlays-in @@ -6042,6 +5339,7 @@ by a #." '(font-lock-fontified t face org-block)) t) ((member dc3 '(" " "")) + ; Just a comment, the plus was not there (org-remove-flyspell-overlays-in beg (match-end 0)) (add-text-properties beg (match-end 0) @@ -6058,9 +5356,10 @@ by a #." "Fontify drawers." (when (re-search-forward org-drawer-regexp limit t) (add-text-properties - (match-beginning 0) (match-end 0) - '(font-lock-fontified t face org-special-keyword)) - (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (line-beginning-position) (line-beginning-position 2) + '(font-lock-fontified t face org-drawer)) + (org-remove-flyspell-overlays-in + (line-beginning-position) (line-beginning-position 2)) t)) (defun org-fontify-macros (limit) @@ -6081,6 +5380,24 @@ by a #." (add-text-properties closing-start end '(invisible t))) t))))) +(defun org-fontify-extend-region (beg end _old-len) + (let ((begin-re "\\(\\\\\\[\\|\\(#\\+begin_\\|\\\\begin{\\)\\S-+\\)") + (end-re "\\(\\\\\\]\\|\\(#\\+end_\\|\\\\end{\\)\\S-+\\)") + (extend (lambda (r1 r2 dir) + (let ((re (replace-regexp-in-string "\\(begin\\|end\\)" r1 + (replace-regexp-in-string "[][]" r2 + (match-string-no-properties 0))))) + (re-search-forward (regexp-quote re) nil t dir))))) + (save-match-data + (save-excursion + (goto-char beg) + (back-to-indentation) + (cond ((looking-at end-re) + (cons (or (funcall extend "begin" "[" -1) beg) end)) + ((looking-at begin-re) + (cons beg (or (funcall extend "end" "]" 1) end))) + (t (cons beg end))))))) + (defun org-activate-footnote-links (limit) "Add text properties for footnotes." (let ((fn (org-footnote-next-reference-or-definition limit))) @@ -6120,25 +5437,13 @@ by a #." (org-display-custom-time (match-beginning 1) (match-end 1))) t)) -(defvar-local org-target-link-regexp nil - "Regular expression matching radio targets in plain text.") - -(defconst org-target-regexp (let ((border "[^<>\n\r \t]")) - (format "<<\\(%s\\|%s[^<>\n\r]*%s\\)>>" - border border border)) - "Regular expression matching a link target.") - -(defconst org-radio-target-regexp (format "<%s>" org-target-regexp) - "Regular expression matching a radio target.") - -(defconst org-any-target-regexp - (format "%s\\|%s" org-radio-target-regexp org-target-regexp) - "Regular expression matching any target.") - (defun org-activate-target-links (limit) "Add text properties for target matches." (when org-target-link-regexp (let ((case-fold-search t)) + ;; `org-target-link-regexp' matches one character before the + ;; actual target. + (unless (bolp) (forward-char -1)) (when (re-search-forward org-target-link-regexp limit t) (org-remove-flyspell-overlays-in (match-beginning 1) (match-end 1)) (add-text-properties (match-beginning 1) (match-end 1) @@ -6149,113 +5454,57 @@ by a #." (org-rear-nonsticky-at (match-end 1)) t)))) -(defun org-update-radio-target-regexp () - "Find all radio targets in this file and update the regular expression. -Also refresh fontification if needed." - (interactive) - (let ((old-regexp org-target-link-regexp) - (before-re "\\(?:^\\|[^[:alnum:]]\\)\\(") - (after-re "\\)\\(?:$\\|[^[:alnum:]]\\)") - (targets - (org-with-wide-buffer - (goto-char (point-min)) - (let (rtn) - (while (re-search-forward org-radio-target-regexp nil t) - ;; Make sure point is really within the object. - (backward-char) - (let ((obj (org-element-context))) - (when (eq (org-element-type obj) 'radio-target) - (cl-pushnew (org-element-property :value obj) rtn - :test #'equal)))) - rtn)))) - (setq org-target-link-regexp - (and targets - (concat before-re - (mapconcat - (lambda (x) - (replace-regexp-in-string - " +" "\\s-+" (regexp-quote x) t t)) - targets - "\\|") - after-re))) - (unless (equal old-regexp org-target-link-regexp) - ;; Clean-up cache. - (let ((regexp (cond ((not old-regexp) org-target-link-regexp) - ((not org-target-link-regexp) old-regexp) - (t - (concat before-re - (mapconcat - (lambda (re) - (substring re (length before-re) - (- (length after-re)))) - (list old-regexp org-target-link-regexp) - "\\|") - after-re))))) - (org-with-wide-buffer - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (org-element-cache-refresh (match-beginning 1))))) - ;; Re fontify buffer. - (when (memq 'radio org-highlight-links) - (org-restart-font-lock))))) - -(defun org-hide-wide-columns (limit) - (let (s e) - (setq s (text-property-any (point) (or limit (point-max)) - 'org-cwidth t)) - (when s - (setq e (next-single-property-change s 'org-cwidth)) - (add-text-properties s e '(invisible org-cwidth)) - (goto-char e) - t))) - (defvar org-latex-and-related-regexp nil "Regular expression for highlighting LaTeX, entities and sub/superscript.") (defun org-compute-latex-and-related-regexp () "Compute regular expression for LaTeX, entities and sub/superscript. Result depends on variable `org-highlight-latex-and-related'." - (setq-local - org-latex-and-related-regexp - (let* ((re-sub - (cond ((not (memq 'script org-highlight-latex-and-related)) nil) - ((eq org-use-sub-superscripts '{}) - (list org-match-substring-with-braces-regexp)) - (org-use-sub-superscripts (list org-match-substring-regexp)))) - (re-latex - (when (memq 'latex org-highlight-latex-and-related) - (let ((matchers (plist-get org-format-latex-options :matchers))) - (delq nil - (mapcar (lambda (x) - (and (member (car x) matchers) (nth 1 x))) - org-latex-regexps))))) - (re-entities - (when (memq 'entities org-highlight-latex-and-related) - (list "\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\($\\|{}\\|[^[:alpha:]]\\)")))) - (mapconcat 'identity (append re-latex re-entities re-sub) "\\|")))) - -(defun org-do-latex-and-related (limit) + (let ((re-sub + (cond ((not (memq 'script org-highlight-latex-and-related)) nil) + ((eq org-use-sub-superscripts '{}) + (list org-match-substring-with-braces-regexp)) + (org-use-sub-superscripts (list org-match-substring-regexp)))) + (re-latex + (when (or (memq 'latex org-highlight-latex-and-related) + (memq 'native org-highlight-latex-and-related)) + (let ((matchers (plist-get org-format-latex-options :matchers))) + (delq nil + (mapcar (lambda (x) + (and (member (car x) matchers) (nth 1 x))) + org-latex-regexps))))) + (re-entities + (when (memq 'entities org-highlight-latex-and-related) + (list "\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\ +\\($\\|{}\\|[^[:alpha:]]\\)")))) + (setq-local org-latex-and-related-regexp + (mapconcat #'identity + (append re-latex re-entities re-sub) + "\\|")))) + +(defun org-do-latex-and-related (_limit) "Highlight LaTeX snippets and environments, entities and sub/superscript. -LIMIT bounds the search for syntax to highlight. Stop at first -highlighted object, if any. Return t if some highlighting was -done, nil otherwise." +Stop at first highlighted object, if any. Return t if some +highlighting was done, nil otherwise." (when (org-string-nw-p org-latex-and-related-regexp) (catch 'found - (while (re-search-forward org-latex-and-related-regexp limit t) - (unless - (cl-some - (lambda (f) - (memq f '(org-code org-verbatim underline org-special-keyword))) - (save-excursion - (goto-char (1+ (match-beginning 0))) - (face-at-point nil t))) - (let ((offset (if (memq (char-after (1+ (match-beginning 0))) - '(?_ ?^)) - 1 - 0))) - (font-lock-prepend-text-property - (+ offset (match-beginning 0)) (match-end 0) - 'face 'org-latex-and-related) + (while (re-search-forward org-latex-and-related-regexp + nil t) ;; on purpose, we ignore LIMIT + (unless (cl-some (lambda (f) (memq f '(org-code org-verbatim underline + org-special-keyword))) + (save-excursion + (goto-char (1+ (match-beginning 0))) + (face-at-point nil t))) + (let* ((offset (if (memq (char-after (1+ (match-beginning 0))) + '(?_ ?^)) + 1 + 0)) + (start (+ offset (match-beginning 0))) + (end (match-end 0))) + (if (memq 'native org-highlight-latex-and-related) + (org-src-font-lock-fontify-block "latex" start end) + (font-lock-prepend-text-property start end + 'face 'org-latex-and-related)) (add-text-properties (+ offset (match-beginning 0)) (match-end 0) '(font-lock-multiline t))) (throw 'found t))) @@ -6268,8 +5517,7 @@ done, nil otherwise." (font-lock-mode 1))) (defun org-activate-tags (limit) - (when (re-search-forward - "^\\*+.*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$" limit t) + (when (re-search-forward org-tag-line-re limit t) (org-remove-flyspell-overlays-in (match-beginning 1) (match-end 1)) (add-text-properties (match-beginning 1) (match-end 1) (list 'mouse-face 'highlight @@ -6365,12 +5613,12 @@ needs to be inserted at a specific position in the font-lock sequence.") '("^[ \t]*| *\\([#*]\\) *|" (1 'org-formula t)) '("^[ \t]*|\\( *\\([$!_^/]\\) *|.*\\)|" (1 'org-formula t)) '("| *\\(<[lrc]?[0-9]*>\\)" (1 'org-formula t)) - ;; Drawers - '(org-fontify-drawers) ;; Properties (list org-property-re '(1 'org-special-keyword t) '(3 'org-property-value t)) + ;; Drawers + '(org-fontify-drawers) ;; Link related fontification. '(org-activate-links) (when (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend))) @@ -6378,12 +5626,12 @@ needs to be inserted at a specific position in the font-lock sequence.") (when (memq 'date lk) '(org-activate-dates (0 'org-date t))) (when (memq 'footnote lk) '(org-activate-footnote-links)) ;; Targets. - (list org-any-target-regexp '(0 'org-target t)) + (list org-radio-target-regexp '(0 'org-target t)) + (list org-target-regexp '(0 'org-target t)) ;; Diary sexps. '("^&?%%(.*\\|<%%([^>\n]*?>" (0 'org-sexp-date t)) ;; Macro '(org-fontify-macros) - '(org-hide-wide-columns (0 nil append)) ;; TODO keyword (list (format org-heading-keyword-regexp-format org-todo-regexp) @@ -6448,6 +5696,8 @@ needs to be inserted at a specific position in the font-lock sequence.") (setq-local org-font-lock-keywords org-font-lock-extra-keywords) (setq-local font-lock-defaults '(org-font-lock-keywords t nil nil backward-paragraph)) + (setq-local font-lock-extend-after-change-region-function + #'org-fontify-extend-region) (kill-local-variable 'font-lock-keywords) nil)) @@ -6660,21 +5910,250 @@ and subscripts." (list 'invisible t)))) t))) -;;;; Visibility cycling, including org-goto and indirect buffer +(defun org-remove-empty-overlays-at (pos) + "Remove outline overlays that do not contain non-white stuff." + (dolist (o (overlays-at pos)) + (and (eq 'outline (overlay-get o 'invisible)) + (not (string-match "\\S-" (buffer-substring (overlay-start o) + (overlay-end o)))) + (delete-overlay o)))) + +(defun org-show-empty-lines-in-parent () + "Move to the parent and re-show empty lines before visible headlines." + (save-excursion + (let ((context (if (org-up-heading-safe) 'children 'overview))) + (org-cycle-show-empty-lines context)))) + +(defun org-files-list () + "Return `org-agenda-files' list, plus all open Org files. +This is useful for operations that need to scan all of a user's +open and agenda-wise Org files." + (let ((files (mapcar #'expand-file-name (org-agenda-files)))) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (and (derived-mode-p 'org-mode) (buffer-file-name)) + (cl-pushnew (expand-file-name (buffer-file-name)) files + :test #'equal)))) + files)) + +(defsubst org-entry-beginning-position () + "Return the beginning position of the current entry." + (save-excursion (org-back-to-heading t) (point))) + +(defsubst org-entry-end-position () + "Return the end position of the current entry." + (save-excursion (outline-next-heading) (point))) + +(defun org-subtree-end-visible-p () + "Is the end of the current subtree visible?" + (pos-visible-in-window-p + (save-excursion (org-end-of-subtree t) (point)))) + +(defun org-first-headline-recenter () + "Move cursor to the first headline and recenter the headline." + (let ((window (get-buffer-window))) + (when window + (goto-char (point-min)) + (when (re-search-forward (concat "^\\(" org-outline-regexp "\\)") nil t) + (set-window-start window (line-beginning-position)))))) + + +;;; Visibility (headlines, blocks, drawers) + +;;;; Headlines visibility + +(defun org-show-entry () + "Show the body directly following this heading. +Show the heading too, if it is currently invisible." + (interactive) + (save-excursion + (ignore-errors + (org-back-to-heading t) + (org-flag-region + (line-end-position 0) + (save-excursion + (if (re-search-forward + (concat "[\r\n]\\(" org-outline-regexp "\\)") nil t) + (match-beginning 1) + (point-max))) + nil + 'outline)))) + +(defun org-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." + (interactive "p") + (save-excursion + (org-back-to-heading t) + (let* ((current-level (funcall outline-level)) + (max-level (org-get-valid-level + current-level + (if level (prefix-numeric-value level) 1))) + (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 + (cond + ((not (featurep 'org-inlinetask)) "") + (org-odd-levels-only (- (* 2 org-inlinetask-min-level) + 3)) + (t (1- org-inlinetask-min-level)))))) + ;; Display parent heading. + (org-flag-heading nil) + (forward-line) + ;; Display children. First child may be deeper than expected + ;; 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)) + (org-flag-heading nil))))) + +(defun org-show-subtree () + "Show everything after this heading at deeper levels." + (interactive) + (org-flag-region + (point) (save-excursion (org-end-of-subtree t t)) nil 'outline)) -;;; Cycling +;;;; Blocks visibility + +(defun org-hide-block-toggle-maybe () + "Toggle visibility of block at point. +Unlike to `org-hide-block-toggle', this function does not throw +an error. Return a non-nil value when toggling is successful." + (interactive) + (ignore-errors (org-hide-block-toggle))) + +(defun org-hide-block-toggle (&optional force) + "Toggle the visibility of the current block. +When optional argument FORCE is `off', make block visible. If it +is non-nil, hide it unconditionally. Throw an error when not at +a block. Return a non-nil value when toggling is successful." + (interactive) + (let ((element (org-element-at-point))) + (unless (memq (org-element-type element) + '(center-block comment-block dynamic-block example-block + export-block quote-block special-block + src-block verse-block)) + (user-error "Not at a block")) + (let* ((post (org-element-property :post-affiliated element)) + (start (save-excursion + (goto-char post) + (line-end-position))) + (end (save-excursion + (goto-char (org-element-property :end element)) + (skip-chars-backward " \t\n") + (line-end-position)))) + ;; Do nothing when not before or at the block opening line or at + ;; the block closing line. + (unless (let ((eol (line-end-position))) (and (> eol start) (/= eol end))) + (cond ((eq force 'off) + (org-flag-region start end nil 'org-hide-block)) + (force + (org-flag-region start end t 'org-hide-block)) + ((eq (get-char-property start 'invisible) 'org-hide-block) + (org-flag-region start end nil 'org-hide-block)) + (t + (org-flag-region start end t 'org-hide-block))) + ;; When the block is hidden away, make sure point is left in + ;; a visible part of the buffer. + (when (invisible-p (max (1- (point)) (point-min))) + (goto-char post)) + ;; Signal success. + t)))) + +(defun org-hide-block-toggle-all () + "Toggle the visibility of all blocks in the current buffer." + (org-block-map 'org-hide-block-toggle)) + +(defun org-hide-block-all () + "Fold all blocks in the current buffer." + (interactive) + (org-show-all '(blocks)) + (org-block-map 'org-hide-block-toggle-maybe)) + +;;;; Drawers visibility + +(defun org-cycle-hide-drawers (state &optional exceptions) + "Re-hide all drawers after a visibility state change. +STATE should be one of the symbols listed in the docstring of +`org-cycle-hook'. When non-nil, optional argument EXCEPTIONS is +a list of strings specifying which drawers should not be hidden." + (when (and (derived-mode-p 'org-mode) + (not (memq state '(overview folded contents)))) + (save-excursion + (let* ((globalp (eq state 'all)) + (beg (if globalp (point-min) (point))) + (end (if globalp (point-max) + (if (eq state 'children) + (save-excursion (outline-next-heading) (point)) + (org-end-of-subtree t))))) + (goto-char beg) + (while (re-search-forward org-drawer-regexp (max end (point)) t) + (unless (member-ignore-case (match-string 1) exceptions) + (let ((drawer (org-element-at-point))) + (when (memq (org-element-type drawer) '(drawer property-drawer)) + (org-flag-drawer t drawer) + ;; 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)))))))))) + +(defun org-flag-drawer (flag &optional element beg end) + "When FLAG is non-nil, hide the drawer we are at. +Otherwise make it visible. + +When optional argument ELEMENT is a parsed drawer, as returned by +`org-element-at-point', hide or show that drawer instead. + +When buffer positions BEG and END are provided, hide or show that +region as a drawer without further ado." + (if (and beg end) (org-flag-region beg end flag 'org-hide-drawer) + (let ((drawer (or element + (and (save-excursion + (beginning-of-line) + (looking-at-p org-drawer-regexp)) + (org-element-at-point))))) + (when (memq (org-element-type drawer) '(drawer property-drawer)) + (let ((post (org-element-property :post-affiliated drawer))) + (org-flag-region + (save-excursion (goto-char post) (line-end-position)) + (save-excursion (goto-char (org-element-property :end drawer)) + (skip-chars-backward " \t\n") + (line-end-position)) + flag 'org-hide-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))) + (goto-char post))))))) + +;;;; Visibility cycling (defvar-local org-cycle-global-status nil) (put 'org-cycle-global-status 'org-state t) (defvar-local org-cycle-subtree-status nil) (put 'org-cycle-subtree-status 'org-state t) -(defvar org-inlinetask-min-level) - -(defun org-unlogged-message (&rest args) - "Display a message, but avoid logging it in the *Messages* buffer." - (let ((message-log-max nil)) - (apply 'message args))) +(defun org-show-all (&optional types) + "Show all contents in the visible part of the buffer. +By default, the function expands headings, blocks and drawers. +When optional argument TYPE is a list of symbols among `blocks', +`drawers' and `headings', to only expand one specific type." + (interactive) + (dolist (type (or types '(blocks drawers headings))) + (org-flag-region (point-min) (point-max) nil + (pcase type + (`blocks 'org-hide-block) + (`drawers 'org-hide-drawer) + (`headings 'outline) + (_ (error "Invalid type: %S" type)))))) ;;;###autoload (defun org-cycle (&optional arg) @@ -6766,7 +6245,7 @@ if the variable `org-cycle-global-at-bob' is t." (org-unlogged-message "Startup visibility, plus VISIBILITY properties")) ((equal arg '(64)) - (outline-show-all) + (org-show-all) (org-unlogged-message "Entire buffer visible, including drawers")) ((equal arg '(4)) (org-cycle-internal-global)) @@ -6825,8 +6304,6 @@ Use `\\[org-edit-special]' to edit table.el tables")) ((run-hook-with-args-until-success 'org-tab-after-check-for-cycling-hook)) - ((org-try-structure-completion)) - ((run-hook-with-args-until-success 'org-tab-before-tab-emulation-hook)) @@ -6869,7 +6346,7 @@ Use `\\[org-edit-special]' to edit table.el tables")) (eq org-cycle-global-status 'contents)) ;; We just showed the table of contents - now show everything (run-hook-with-args 'org-pre-cycle-hook 'all) - (outline-show-all) + (org-show-all '(headings blocks)) (unless ga (org-unlogged-message "SHOW ALL")) (setq org-cycle-global-status 'all) (run-hook-with-args 'org-cycle-hook 'all)) @@ -6885,11 +6362,6 @@ Use `\\[org-edit-special]' to edit table.el tables")) (defvar org-called-with-limited-levels nil "Non-nil when `org-with-limited-levels' is currently active.") -(defun org-invisible-p (&optional pos) - "Non-nil if the character after POS is invisible. -If POS is nil, use `point' instead." - (get-char-property (or pos (point)) 'invisible)) - (defun org-cycle-internal-local () "Do the local cycling action." (let ((goal-column 0) eoh eol eos has-children children-skipped struct) @@ -6947,11 +6419,6 @@ If POS is nil, use `point' instead." (org-show-entry) (org-with-limited-levels (org-show-children)) (org-show-set-visibility 'canonical) - ;; FIXME: This slows down the func way too much. - ;; How keep drawers hidden in subtree anyway? - ;; (when (memq 'org-cycle-hide-drawers org-cycle-hook) - ;; (org-cycle-hide-drawers 'subtree)) - ;; Fold every list in subtree to top-level items. (when (eq org-cycle-include-plain-lists 'integrate) (save-excursion @@ -6979,7 +6446,7 @@ If POS is nil, use `point' instead." ;; now show everything. (unless (org-before-first-heading-p) (run-hook-with-args 'org-pre-cycle-hook 'subtree)) - (outline-flag-region eoh eos nil) + (org-flag-region eoh eos nil 'outline) (org-unlogged-message (if children-skipped "SUBTREE (NO CHILDREN)" "SUBTREE")) (setq org-cycle-subtree-status 'subtree) @@ -6988,7 +6455,7 @@ If POS is nil, use `point' instead." (t ;; Default action: hide the subtree. (run-hook-with-args 'org-pre-cycle-hook 'folded) - (outline-flag-region eoh eos t) + (org-flag-region eoh eos t 'outline) (org-unlogged-message "FOLDED") (setq org-cycle-subtree-status 'folded) (unless (org-before-first-heading-p) @@ -7004,7 +6471,7 @@ With a numeric prefix, show all headlines up to that level." (if (derived-mode-p 'org-mode) org-cycle-include-plain-lists nil))) (cond ((integerp arg) - (outline-show-all) + (org-show-all '(headings blocks)) (outline-hide-sublevels arg) (setq org-cycle-global-status 'contents)) ((equal arg '(4)) @@ -7022,49 +6489,42 @@ With a numeric prefix, show all headlines up to that level." (org-content)) ((or (eq org-startup-folded 'showeverything) (eq org-startup-folded nil)) - (outline-show-all))) + (org-show-all))) (unless (eq org-startup-folded 'showeverything) (when org-hide-block-startup (org-hide-block-all)) - (org-set-visibility-according-to-property 'no-cleanup) + (org-set-visibility-according-to-property) (org-cycle-hide-archived-subtrees 'all) (org-cycle-hide-drawers 'all) (org-cycle-show-empty-lines t))) -(defun org-set-visibility-according-to-property (&optional no-cleanup) - "Switch subtree visibilities according to :VISIBILITY: property." +(defun org-set-visibility-according-to-property () + "Switch subtree visibility according to VISIBILITY property." (interactive) - (org-with-wide-buffer - (goto-char (point-min)) - (while (re-search-forward "^[ \t]*:VISIBILITY:" nil t) - (if (not (org-at-property-p)) (outline-next-heading) - (let ((state (match-string 3))) - (save-excursion - (org-back-to-heading t) - (outline-hide-subtree) - (org-reveal)) - (cond - ((equal state "folded") - (outline-hide-subtree) - (org-end-of-subtree t t)) - ((equal state "children") - (org-show-hidden-entry) - (org-show-children)) - ((equal state "content") - (save-excursion - (save-restriction - (org-narrow-to-subtree) - (org-content))) - (org-end-of-subtree t t)) - ((member state '("all" "showall")) - (outline-show-subtree)))))) - (unless no-cleanup - (org-cycle-hide-archived-subtrees 'all) - (org-cycle-hide-drawers 'all) - (org-cycle-show-empty-lines 'all)))) - -;; This function uses outline-regexp instead of the more fundamental -;; org-outline-regexp so that org-cycle-global works outside of Org -;; buffers, where outline-regexp is needed. + (let ((regexp (org-re-property "VISIBILITY"))) + (org-with-point-at 1 + (while (re-search-forward regexp nil t) + (let ((state (match-string 3))) + (if (not (org-at-property-p)) (outline-next-heading) + (save-excursion + (org-back-to-heading t) + (org-flag-subtree t) + (org-reveal) + (pcase state + ("folded" + (org-flag-subtree t)) + ("children" + (org-show-hidden-entry) + (org-show-children)) + ("content" + (save-excursion + (save-restriction + (org-narrow-to-subtree) + (org-content)))) + ((or "all" "showall") + (outline-show-subtree)) + (_ nil))) + (org-end-of-subtree))))))) + (defun org-overview () "Switch to overview mode, showing only top-level headlines. This shows all headlines with a level equal or greater than the level @@ -7076,7 +6536,7 @@ results." (let ((level (save-excursion (goto-char (point-min)) - (when (re-search-forward (concat "^" outline-regexp) nil t) + (when (re-search-forward org-outline-regexp-bol nil t) (goto-char (match-beginning 0)) (funcall outline-level))))) (and level (outline-hide-sublevels level))))) @@ -7112,14 +6572,6 @@ This function is the default value of the hook `org-cycle-hook'." ((eq state 'children) (or (org-subtree-end-visible-p) (recenter 1))) ((eq state 'subtree) (or (org-subtree-end-visible-p) (recenter 1)))))) -(defun org-remove-empty-overlays-at (pos) - "Remove outline overlays that do not contain non-white stuff." - (dolist (o (overlays-at pos)) - (and (eq 'outline (overlay-get o 'invisible)) - (not (string-match "\\S-" (buffer-substring (overlay-start o) - (overlay-end o)))) - (delete-overlay o)))) - (defun org-clean-visibility-after-subtree-move () "Fix visibility issues after moving a subtree." ;; First, find a reasonable region to look at: @@ -7145,11 +6597,10 @@ This function is the default value of the hook `org-cycle-hook'." (goto-char (point-min)) (while (re-search-forward re nil t) (when (and (not (org-invisible-p)) - (save-excursion - (goto-char (point-at-eol)) (org-invisible-p))) + (org-invisible-p (line-end-position))) (outline-hide-entry)))) - (org-cycle-show-empty-lines 'overview) - (org-cycle-hide-drawers 'overview))))) + (org-cycle-hide-drawers 'all) + (org-cycle-show-empty-lines 'overview))))) (defun org-cycle-show-empty-lines (state) "Show empty lines above all visible headlines. @@ -7185,7 +6636,7 @@ are at least `org-cycle-separator-lines' empty lines before the headline." (goto-char (match-beginning 0)) (skip-chars-backward " \t\n") (line-end-position))))) - (outline-flag-region b e nil)))))))) + (org-flag-region b e nil 'outline)))))))) ;; Never hide empty lines at the end of the file. (save-excursion (goto-char (point-max)) @@ -7193,434 +6644,80 @@ are at least `org-cycle-separator-lines' empty lines before the headline." (outline-end-of-heading) (when (and (looking-at "[ \t\n]+") (= (match-end 0) (point-max))) - (outline-flag-region (point) (match-end 0) nil)))) - -(defun org-show-empty-lines-in-parent () - "Move to the parent and re-show empty lines before visible headlines." - (save-excursion - (let ((context (if (org-up-heading-safe) 'children 'overview))) - (org-cycle-show-empty-lines context)))) - -(defun org-files-list () - "Return `org-agenda-files' list, plus all open Org files. -This is useful for operations that need to scan all of a user's -open and agenda-wise Org files." - (let ((files (mapcar #'expand-file-name (org-agenda-files)))) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (and (derived-mode-p 'org-mode) (buffer-file-name)) - (cl-pushnew (expand-file-name (buffer-file-name)) files - :test #'equal)))) - files)) - -(defsubst org-entry-beginning-position () - "Return the beginning position of the current entry." - (save-excursion (org-back-to-heading t) (point))) - -(defsubst org-entry-end-position () - "Return the end position of the current entry." - (save-excursion (outline-next-heading) (point))) - -(defun org-cycle-hide-drawers (state &optional exceptions) - "Re-hide all drawers after a visibility state change. -STATE should be one of the symbols listed in the docstring of -`org-cycle-hook'. When non-nil, optional argument EXCEPTIONS is -a list of strings specifying which drawers should not be hidden." - (when (and (derived-mode-p 'org-mode) - (not (memq state '(overview folded contents)))) - (save-excursion - (let* ((globalp (eq state 'all)) - (beg (if globalp (point-min) (point))) - (end (if globalp (point-max) - (if (eq state 'children) - (save-excursion (outline-next-heading) (point)) - (org-end-of-subtree t))))) - (goto-char beg) - (while (re-search-forward org-drawer-regexp (max end (point)) t) - (unless (member-ignore-case (match-string 1) exceptions) - (let ((drawer (org-element-at-point))) - (when (memq (org-element-type drawer) '(drawer property-drawer)) - (org-flag-drawer t drawer) - ;; 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)))))))))) - -(defun org-flag-drawer (flag &optional element) - "When FLAG is non-nil, hide the drawer we are at. -Otherwise make it visible. When optional argument ELEMENT is -a parsed drawer, as returned by `org-element-at-point', hide or -show that drawer instead." - (let ((drawer (or element - (and (save-excursion - (beginning-of-line) - (looking-at-p org-drawer-regexp)) - (org-element-at-point))))) - (when (memq (org-element-type drawer) '(drawer property-drawer)) - (let ((post (org-element-property :post-affiliated drawer))) - (save-excursion - (outline-flag-region - (progn (goto-char post) (line-end-position)) - (progn (goto-char (org-element-property :end drawer)) - (skip-chars-backward " \r\t\n") - (line-end-position)) - flag)) - ;; When the drawer is hidden away, make sure point lies in - ;; a visible part of the buffer. - (when (and flag (> (line-beginning-position) post)) - (goto-char post)))))) + (org-flag-region (point) (match-end 0) nil 'outline)))) -(defun org-subtree-end-visible-p () - "Is the end of the current subtree visible?" - (pos-visible-in-window-p - (save-excursion (org-end-of-subtree t) (point)))) +;;;; Reveal point location -(defun org-first-headline-recenter () - "Move cursor to the first headline and recenter the headline." - (let ((window (get-buffer-window))) - (when window - (goto-char (point-min)) - (when (re-search-forward (concat "^\\(" org-outline-regexp "\\)") nil t) - (set-window-start window (line-beginning-position)))))) - -;;; Saving and restoring visibility - -(defun org-outline-overlay-data (&optional use-markers) - "Return a list of the locations of all outline overlays. -These are overlays with the `invisible' property value `outline'. -The return value is a list of cons cells, with start and stop -positions for each overlay. -If USE-MARKERS is set, return the positions as markers." - (let (beg end) - (org-with-wide-buffer - (delq nil - (mapcar (lambda (o) - (when (eq (overlay-get o 'invisible) 'outline) - (setq beg (overlay-start o) - end (overlay-end o)) - (and beg end (> end beg) - (if use-markers - (cons (copy-marker beg) - (copy-marker end t)) - (cons beg end))))) - (overlays-in (point-min) (point-max))))))) - -(defun org-set-outline-overlay-data (data) - "Create visibility overlays for all positions in DATA. -DATA should have been made by `org-outline-overlay-data'." - (org-with-wide-buffer - (outline-show-all) - (dolist (c data) (outline-flag-region (car c) (cdr c) t)))) - -;;; Folding of blocks - -(defvar-local org-hide-block-overlays nil - "Overlays hiding blocks.") +(defun org-show-context (&optional key) + "Make sure point and context are visible. +Optional argument KEY, when non-nil, is a symbol. See +`org-show-context-detail' for allowed values and how much is to +be shown." + (org-show-set-visibility + (cond ((symbolp org-show-context-detail) org-show-context-detail) + ((cdr (assq key org-show-context-detail))) + (t (cdr (assq 'default org-show-context-detail)))))) -(defun org-block-map (function &optional start end) - "Call FUNCTION at the head of all source blocks in the current buffer. -Optional arguments START and END can be used to limit the range." - (let ((start (or start (point-min))) - (end (or end (point-max)))) +(defun org-show-set-visibility (detail) + "Set visibility around point according to DETAIL. +DETAIL is either nil, `minimal', `local', `ancestors', `lineage', +`tree', `canonical' or t. See `org-show-context-detail' for more +information." + ;; Show current heading and possibly its entry, following headline + ;; or all children. + (if (and (org-at-heading-p) (not (eq detail 'local))) + (org-flag-heading nil) + (org-show-entry) + ;; If point is hidden within a drawer or a block, make sure to + ;; expose it. + (dolist (o (overlays-at (point))) + (when (memq (overlay-get o 'invisible) + '(org-hide-block org-hide-drawer outline)) + (delete-overlay o))) + (unless (org-before-first-heading-p) + (org-with-limited-levels + (cl-case detail + ((tree canonical t) (org-show-children)) + ((nil minimal ancestors)) + (t (save-excursion + (outline-next-heading) + (org-flag-heading nil))))))) + ;; Show all siblings. + (when (eq detail 'lineage) (org-show-siblings)) + ;; Show ancestors, possibly with their children. + (when (memq detail '(ancestors lineage tree canonical t)) (save-excursion - (goto-char start) - (while (and (< (point) end) (re-search-forward org-block-regexp end t)) - (save-excursion - (save-match-data - (goto-char (match-beginning 0)) - (funcall function))))))) - -(defun org-hide-block-toggle-all () - "Toggle the visibility of all blocks in the current buffer." - (org-block-map 'org-hide-block-toggle)) + (while (org-up-heading-safe) + (org-flag-heading nil) + (when (memq detail '(canonical t)) (org-show-entry)) + (when (memq detail '(tree canonical t)) (org-show-children)))))) -(defun org-hide-block-all () - "Fold all blocks in the current buffer." - (interactive) - (org-show-block-all) - (org-block-map 'org-hide-block-toggle-maybe)) +(defvar org-reveal-start-hook nil + "Hook run before revealing a location.") -(defun org-show-block-all () - "Unfold all blocks in the current buffer." - (interactive) - (mapc #'delete-overlay org-hide-block-overlays) - (setq org-hide-block-overlays nil)) +(defun org-reveal (&optional siblings) + "Show current entry, hierarchy above it, and the following headline. -(defun org-hide-block-toggle-maybe () - "Toggle visibility of block at point. -Unlike to `org-hide-block-toggle', this function does not throw -an error. Return a non-nil value when toggling is successful." - (interactive) - (ignore-errors (org-hide-block-toggle))) +This can be used to show a consistent set of context around +locations exposed with `org-show-context'. -(defun org-hide-block-toggle (&optional force) - "Toggle the visibility of the current block. -When optional argument FORCE is `off', make block visible. If it -is non-nil, hide it unconditionally. Throw an error when not at -a block. Return a non-nil value when toggling is successful." - (interactive) - (let ((element (org-element-at-point))) - (unless (memq (org-element-type element) - '(center-block comment-block dynamic-block example-block - export-block quote-block special-block - src-block verse-block)) - (user-error "Not at a block")) - (let* ((start (save-excursion - (goto-char (org-element-property :post-affiliated element)) - (line-end-position))) - (end (save-excursion - (goto-char (org-element-property :end element)) - (skip-chars-backward " \r\t\n") - (line-end-position))) - (overlays (overlays-at start))) - (cond - ;; Do nothing when not before or at the block opening line or - ;; at the block closing line. - ((let ((eol (line-end-position))) (and (> eol start) (/= eol end))) nil) - ((and (not (eq force 'off)) - (not (memq t (mapcar - (lambda (o) - (eq (overlay-get o 'invisible) 'org-hide-block)) - overlays)))) - (let ((ov (make-overlay start end))) - (overlay-put ov 'invisible 'org-hide-block) - ;; Make the block accessible to `isearch'. - (overlay-put - ov 'isearch-open-invisible - (lambda (ov) - (when (memq ov org-hide-block-overlays) - (setq org-hide-block-overlays (delq ov org-hide-block-overlays))) - (when (eq (overlay-get ov 'invisible) 'org-hide-block) - (delete-overlay ov)))) - (push ov org-hide-block-overlays) - ;; When the block is hidden away, make sure point is left in - ;; a visible part of the buffer. - (when (> (line-beginning-position) start) - (goto-char start) - (beginning-of-line)) - ;; Signal successful toggling. - t)) - ((or (not force) (eq force 'off)) - (dolist (ov overlays t) - (when (memq ov org-hide-block-overlays) - (setq org-hide-block-overlays (delq ov org-hide-block-overlays))) - (when (eq (overlay-get ov 'invisible) 'org-hide-block) - (delete-overlay ov)))))))) - -;; Remove overlays when changing major mode -(add-hook 'org-mode-hook - (lambda () (add-hook 'change-major-mode-hook - 'org-show-block-all 'append 'local))) - -;;; Org-goto - -(defvar org-goto-window-configuration nil) -(defvar org-goto-marker nil) -(defvar org-goto-map) -(defun org-goto-map () - "Set the keymap `org-goto'." - (setq org-goto-map - (let ((map (make-sparse-keymap))) - (let ((cmds '(isearch-forward isearch-backward kill-ring-save set-mark-command - mouse-drag-region universal-argument org-occur))) - (dolist (cmd cmds) - (substitute-key-definition cmd cmd map global-map))) - (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) - (org-defkey map [(right)] 'org-goto-right) - (org-defkey map [(control ?g)] 'org-goto-quit) - (org-defkey map "\C-i" 'org-cycle) - (org-defkey map [(tab)] 'org-cycle) - (org-defkey map [(down)] 'outline-next-visible-heading) - (org-defkey map [(up)] 'outline-previous-visible-heading) - (if org-goto-auto-isearch - (if (fboundp 'define-key-after) - (define-key-after map [t] 'org-goto-local-auto-isearch) - nil) - (org-defkey map "q" 'org-goto-quit) - (org-defkey map "n" 'outline-next-visible-heading) - (org-defkey map "p" 'outline-previous-visible-heading) - (org-defkey map "f" 'outline-forward-same-level) - (org-defkey map "b" 'outline-backward-same-level) - (org-defkey map "u" 'outline-up-heading)) - (org-defkey map "/" 'org-occur) - (org-defkey map "\C-c\C-n" 'outline-next-visible-heading) - (org-defkey map "\C-c\C-p" 'outline-previous-visible-heading) - (org-defkey map "\C-c\C-f" 'outline-forward-same-level) - (org-defkey map "\C-c\C-b" 'outline-backward-same-level) - (org-defkey map "\C-c\C-u" 'outline-up-heading) - map))) - -(defconst org-goto-help - "Browse buffer copy, to find location or copy text.%s -RET=jump to location C-g=quit and return to previous location -\[Up]/[Down]=next/prev headline TAB=cycle visibility [/] org-occur") - -(defvar org-goto-start-pos) ; dynamically scoped parameter - -(defun org-goto (&optional alternative-interface) - "Look up a different location in the current file, keeping current visibility. - -When you want look-up or go to a different location in a -document, the fastest way is often to fold the entire buffer and -then dive into the tree. This method has the disadvantage, that -the previous location will be folded, which may not be what you -want. - -This command works around this by showing a copy of the current -buffer in an indirect buffer, in overview mode. You can dive -into the tree in that copy, use org-occur and incremental search -to find a location. When pressing RET or `Q', the command -returns to the original buffer in which the visibility is still -unchanged. After RET it will also jump to the location selected -in the indirect buffer and expose the headline hierarchy above. - -With a prefix argument, use the alternative interface: e.g., if -`org-goto-interface' is `outline' use `outline-path-completion'." - (interactive "P") - (org-goto-map) - (let* ((org-refile-targets `((nil . (:maxlevel . ,org-goto-max-level)))) - (org-refile-use-outline-path t) - (org-refile-target-verify-function nil) - (interface - (if (not alternative-interface) - org-goto-interface - (if (eq org-goto-interface 'outline) - 'outline-path-completion - 'outline))) - (org-goto-start-pos (point)) - (selected-point - (if (eq interface 'outline) - (car (org-get-location (current-buffer) org-goto-help)) - (let ((pa (org-refile-get-location "Goto"))) - (org-refile-check-position pa) - (nth 3 pa))))) - (if selected-point - (progn - (org-mark-ring-push org-goto-start-pos) - (goto-char selected-point) - (when (or (org-invisible-p) (org-invisible-p2)) - (org-show-context 'org-goto))) - (message "Quit")))) - -(defvar org-goto-selected-point nil) ; dynamically scoped parameter -(defvar org-goto-exit-command nil) ; dynamically scoped parameter -(defvar org-goto-local-auto-isearch-map) ; defined below - -(defun org-get-location (_buf help) - "Let the user select a location in current buffer. -This function uses a recursive edit. It returns the selected position -or nil." - (org-no-popups - (let ((isearch-mode-map org-goto-local-auto-isearch-map) - (isearch-hide-immediately nil) - (isearch-search-fun-function - (lambda () 'org-goto-local-search-headings)) - (org-goto-selected-point org-goto-exit-command)) - (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 - (make-indirect-buffer (current-buffer) "*org-goto*") - (error (make-indirect-buffer (current-buffer) "*org-goto*")))) - (with-output-to-temp-buffer "*Org Help*" - (princ (format help (if org-goto-auto-isearch - " Just type for auto-isearch." - " n/p/f/b/u to navigate, q to quit.")))) - (org-fit-window-to-buffer (get-buffer-window "*Org Help*")) - (setq buffer-read-only nil) - (let ((org-startup-truncated t) - (org-startup-folded nil) - (org-startup-align-all-tables nil)) - (org-mode) - (org-overview)) - (setq buffer-read-only t) - (if (and (boundp 'org-goto-start-pos) - (integer-or-marker-p org-goto-start-pos)) - (progn (goto-char org-goto-start-pos) - (when (org-invisible-p) - (org-show-set-visibility 'lineage))) - (goto-char (point-min))) - (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*") - (cons org-goto-selected-point org-goto-exit-command)))) - -(defvar org-goto-local-auto-isearch-map (make-sparse-keymap)) -(set-keymap-parent org-goto-local-auto-isearch-map isearch-mode-map) -;; `isearch-other-control-char' was removed in Emacs 24.4. -(if (fboundp 'isearch-other-control-char) - (progn - (define-key org-goto-local-auto-isearch-map "\C-i" 'isearch-other-control-char) - (define-key org-goto-local-auto-isearch-map "\C-m" 'isearch-other-control-char)) - (define-key org-goto-local-auto-isearch-map "\C-i" nil) - (define-key org-goto-local-auto-isearch-map "\C-m" nil) - (define-key org-goto-local-auto-isearch-map [return] nil)) - -(defun org-goto-local-search-headings (string bound noerror) - "Search and make sure that any matches are in headlines." - (catch 'return - (while (if isearch-forward - (search-forward string bound noerror) - (search-backward string bound noerror)) - (when (save-match-data - (and (save-excursion - (beginning-of-line) - (looking-at org-complex-heading-regexp)) - (or (not (match-beginning 5)) - (< (point) (match-beginning 5))))) - (throw 'return (point)))))) - -(defun org-goto-local-auto-isearch () - "Start isearch." - (interactive) - (goto-char (point-min)) - (let ((keys (this-command-keys))) - (when (eq (lookup-key isearch-mode-map keys) 'isearch-printing-char) - (isearch-mode t) - (isearch-process-search-char (string-to-char keys))))) +With optional argument SIBLINGS, on each level of the hierarchy all +siblings are shown. This repairs the tree structure to what it would +look like when opened with hierarchical calls to `org-cycle'. -(defun org-goto-ret (&optional _arg) - "Finish `org-goto' by going to the new location." +With a \\[universal-argument] \\[universal-argument] prefix, \ +go to the parent and show the entire tree." (interactive "P") - (setq org-goto-selected-point (point)) - (setq org-goto-exit-command 'return) - (throw 'exit nil)) - -(defun org-goto-left () - "Finish `org-goto' by going to the new location." - (interactive) - (if (org-at-heading-p) - (progn - (beginning-of-line 1) - (setq org-goto-selected-point (point) - org-goto-exit-command 'left) - (throw 'exit nil)) - (user-error "Not on a heading"))) - -(defun org-goto-right () - "Finish `org-goto' by going to the new location." - (interactive) - (if (org-at-heading-p) - (progn - (setq org-goto-selected-point (point) - org-goto-exit-command 'right) - (throw 'exit nil)) - (user-error "Not on a heading"))) - -(defun org-goto-quit () - "Finish `org-goto' without cursor motion." - (interactive) - (setq org-goto-selected-point nil) - (setq org-goto-exit-command 'quit) - (throw 'exit nil)) + (run-hooks 'org-reveal-start-hook) + (cond ((equal siblings '(4)) (org-show-set-visibility 'canonical)) + ((equal siblings '(16)) + (save-excursion + (when (org-up-heading-safe) + (org-show-subtree) + (run-hook-with-args 'org-cycle-hook 'subtree)))) + (t (org-show-set-visibility 'lineage)))) + ;;; Indirect buffer display of subtrees (defvar org-indirect-dedicated-frame nil @@ -7688,7 +6785,7 @@ frame is not changed." (pop-to-buffer ibuf)) (t (error "Invalid value"))) (narrow-to-region beg end) - (outline-show-all) + (org-show-all '(headings blocks)) (goto-char pos) (run-hook-with-args 'org-cycle-hook 'all) (and (window-live-p cwin) (select-window cwin)))) @@ -7799,22 +6896,24 @@ unconditionally." (member arg '((4) (16))) (and (not invisible-ok) (invisible-p (max (1- (point)) (point-min))))) - ;; Position point at the location of insertion. - (if (not level) ;before first headline - (org-with-limited-levels (outline-next-heading)) - ;; Make sure we end up on a visible headline if INVISIBLE-OK - ;; is nil. - (org-with-limited-levels (org-back-to-heading invisible-ok)) - (cond ((equal arg '(16)) - (org-up-heading-safe) - (org-end-of-subtree t t)) - (t - (org-end-of-subtree t t)))) - (unless (bolp) (insert "\n")) ;ensure final newline + ;; Position point at the location of insertion. Make sure we + ;; end up on a visible headline if INVISIBLE-OK is nil. + (org-with-limited-levels + (if (not level) (outline-next-heading) ;before first headline + (org-back-to-heading invisible-ok) + (when (equal arg '(16)) (org-up-heading-safe)) + (org-end-of-subtree))) + (unless (bolp) (insert "\n")) (unless (and blank? (org-previous-line-empty-p)) (org-N-empty-lines-before-current (if blank? 1 0))) - (insert stars " \n") - (forward-char -1)) + (insert stars " ") + ;; When INVISIBLE-OK is non-nil, ensure newly created headline + ;; is visible. + (unless invisible-ok + (pcase (get-char-property-and-overlay (point) 'invisible) + (`(outline . ,o) + (move-overlay o (overlay-start o) (line-end-position 0))) + (_ nil)))) ;; At a headline... ((org-at-heading-p) (cond ((bolp) @@ -7830,17 +6929,15 @@ unconditionally." ;; Preserve tags. (let ((split (delete-and-extract-region (point) (match-end 4)))) (if (looking-at "[ \t]*$") (replace-match "") - (org-set-tags nil t)) + (org-align-tags)) (end-of-line) (when blank? (insert "\n")) (insert "\n" stars " ") - (when (org-string-nw-p split) (insert split)) - (when (eobp) (save-excursion (insert "\n"))))) + (when (org-string-nw-p split) (insert split)))) (t (end-of-line) (when blank? (insert "\n")) - (insert "\n" stars " ") - (when (eobp) (save-excursion (insert "\n")))))) + (insert "\n" stars " ")))) ;; On regular text, turn line into a headline or split, if ;; appropriate. ((bolp) @@ -7873,27 +6970,27 @@ So this will delete or add empty lines." When NO-TAGS is non-nil, don't include tags. When NO-TODO is non-nil, don't include TODO keywords. When NO-PRIORITY is non-nil, don't include priority cookie. -When NO-COMMENT is non-nil, don't include COMMENT string." - (save-excursion - (org-back-to-heading t) - (let ((case-fold-search nil)) - (looking-at org-complex-heading-regexp) - (let ((todo (and (not no-todo) (match-string 2))) - (priority (and (not no-priority) (match-string 3))) - (headline (pcase (match-string 4) - (`nil "") - ((and (guard no-comment) h) - (replace-regexp-in-string - (eval-when-compile - (format "\\`%s[ \t]+" org-comment-string)) - "" h)) - (h h))) - (tags (and (not no-tags) (match-string 5)))) - (mapconcat #'identity - (delq nil (list todo priority headline tags)) - " "))))) - -(defvar orgstruct-mode) ; defined below +When NO-COMMENT is non-nil, don't include COMMENT string. +Return nil before first heading." + (unless (org-before-first-heading-p) + (save-excursion + (org-back-to-heading t) + (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp) + (let ((todo (and (not no-todo) (match-string 2))) + (priority (and (not no-priority) (match-string 3))) + (headline (pcase (match-string 4) + (`nil "") + ((and (guard no-comment) h) + (replace-regexp-in-string + (eval-when-compile + (format "\\`%s[ \t]+" org-comment-string)) + "" h)) + (h h))) + (tags (and (not no-tags) (match-string 5)))) + (mapconcat #'identity + (delq nil (list todo priority headline tags)) + " ")))))) (defun org-heading-components () "Return the components of the current heading. @@ -7906,24 +7003,13 @@ This is a list with the following elements: - the tags string, or nil." (save-excursion (org-back-to-heading t) - (when (let (case-fold-search) - (looking-at - (if orgstruct-mode - org-heading-regexp - org-complex-heading-regexp))) - (if orgstruct-mode - (list (length (match-string 1)) - (org-reduced-level (length (match-string 1))) - nil - nil - (match-string 2) - nil) - (list (length (match-string 1)) - (org-reduced-level (length (match-string 1))) - (match-string-no-properties 2) - (and (match-end 3) (aref (match-string 3) 2)) - (match-string-no-properties 4) - (match-string-no-properties 5)))))) + (when (let (case-fold-search) (looking-at org-complex-heading-regexp)) + (list (length (match-string 1)) + (org-reduced-level (length (match-string 1))) + (match-string-no-properties 2) + (and (match-end 3) (aref (match-string 3) 2)) + (match-string-no-properties 4) + (match-string-no-properties 5))))) (defun org-get-entry () "Get the entry text, after heading, entire subtree." @@ -7946,7 +7032,7 @@ Set it to HEADING when provided." (if old (replace-match new t t nil 4) (goto-char (or (match-end 3) (match-end 2) (match-end 1))) (insert " " new)) - (org-set-tags nil t) + (org-align-tags) (when (looking-at "[ \t]*$") (replace-match "")))))))) (defun org-insert-heading-after-current () @@ -8142,7 +7228,7 @@ odd number. Returns values greater than 0." (user-error "Cannot promote to level 0. UNDO to recover if necessary")) (t (replace-match up-head nil t))) (unless (= level 1) - (when org-auto-align-tags (org-set-tags nil 'ignore-column)) + (when org-auto-align-tags (org-align-tags)) (when org-adapt-indentation (org-fixup-indentation (- diff)))) (run-hooks 'org-after-promote-entry-hook)))) @@ -8156,7 +7242,7 @@ odd number. Returns values greater than 0." (down-head (concat (make-string (org-get-valid-level level 1) ?*) " ")) (diff (abs (- level (length down-head) -1)))) (replace-match down-head nil t) - (when org-auto-align-tags (org-set-tags nil 'ignore-column)) + (when org-auto-align-tags (org-align-tags)) (when org-adapt-indentation (org-fixup-indentation diff)) (run-hooks 'org-after-demote-entry-hook)))) @@ -8315,7 +7401,7 @@ Assume point is at a heading or an inlinetask beginning." ((looking-at-p org-outline-regexp) (forward-line)) ((looking-at-p "[ \t]*$") (forward-line)) (t - (indent-line-to (+ (org-get-indentation) diff)) + (indent-line-to (+ (current-indentation) diff)) (beginning-of-line) (or (and (looking-at-p "[ \t]*#\\+BEGIN_\\(EXAMPLE\\|SRC\\)") (let ((e (org-element-at-point))) @@ -8384,80 +7470,59 @@ case." "Move the current subtree down past ARG headlines of the same level." (interactive "p") (setq arg (prefix-numeric-value arg)) - (let ((movfunc (if (> arg 0) 'org-get-next-sibling - 'org-get-last-sibling)) - (ins-point (make-marker)) - (cnt (abs arg)) - (col (current-column)) - beg beg0 end txt folded ne-beg ne-end ne-ins ins-end) - ;; Select the tree - (org-back-to-heading) - (setq beg0 (point)) - (save-excursion - (setq ne-beg (org-back-over-empty-lines)) - (setq beg (point))) - (save-match-data - (save-excursion (outline-end-of-heading) - (setq folded (org-invisible-p))) - (progn (org-end-of-subtree nil t) - (unless (eobp) (backward-char)))) - (outline-next-heading) - (setq ne-end (org-back-over-empty-lines)) - (setq end (point)) - (goto-char beg0) - (when (and (> arg 0) (org-first-sibling-p) (< ne-end ne-beg)) - ;; include less whitespace - (save-excursion - (goto-char beg) - (forward-line (- ne-beg ne-end)) - (setq beg (point)))) - ;; Find insertion point, with error handling - (while (> cnt 0) - (or (and (funcall movfunc) (looking-at org-outline-regexp)) - (progn (goto-char beg0) - (user-error "Cannot move past superior level or buffer limit"))) - (setq cnt (1- cnt))) - (when (> arg 0) - ;; Moving forward - still need to move over subtree - (org-end-of-subtree t t) - (save-excursion - (org-back-over-empty-lines) - (or (bolp) (newline)))) - (setq ne-ins (org-back-over-empty-lines)) - (move-marker ins-point (point)) - (setq txt (buffer-substring beg end)) - (org-save-markers-in-region beg end) - (delete-region beg end) - (org-remove-empty-overlays-at beg) - (or (= beg (point-min)) (outline-flag-region (1- beg) beg nil)) - (or (bobp) (outline-flag-region (1- (point)) (point) nil)) - (and (not (bolp)) (looking-at "\n") (forward-char 1)) - (let ((bbb (point))) - (insert-before-markers txt) - (org-reinstall-markers-in-region bbb) - (move-marker ins-point bbb)) - (or (bolp) (insert "\n")) - (setq ins-end (point)) - (goto-char ins-point) - (org-skip-whitespace) - (when (and (< arg 0) - (org-first-sibling-p) - (> ne-ins ne-beg)) - ;; Move whitespace back to beginning - (save-excursion - (goto-char ins-end) - (let ((kill-whole-line t)) - (kill-line (- ne-ins ne-beg)) (point))) - (insert (make-string (- ne-ins ne-beg) ?\n))) - (move-marker ins-point nil) - (if folded - (outline-hide-subtree) - (org-show-entry) - (org-show-children) - (org-cycle-hide-drawers 'children)) - (org-clean-visibility-after-subtree-move) - ;; move back to the initial column we were at - (move-to-column col))) + (org-preserve-local-variables + (let ((movfunc (if (> arg 0) 'org-get-next-sibling + 'org-get-last-sibling)) + (ins-point (make-marker)) + (cnt (abs arg)) + (col (current-column)) + beg end txt folded) + ;; Select the tree + (org-back-to-heading) + (setq beg (point)) + (save-match-data + (save-excursion (outline-end-of-heading) + (setq folded (org-invisible-p))) + (progn (org-end-of-subtree nil t) + (unless (eobp) (backward-char)))) + (outline-next-heading) + (setq end (point)) + (goto-char beg) + ;; Find insertion point, with error handling + (while (> cnt 0) + (unless (and (funcall movfunc) (looking-at org-outline-regexp)) + (goto-char beg) + (user-error "Cannot move past superior level or buffer limit")) + (setq cnt (1- cnt))) + (when (> arg 0) + ;; Moving forward - still need to move over subtree + (org-end-of-subtree t t) + (save-excursion + (org-back-over-empty-lines) + (or (bolp) (newline)))) + (move-marker ins-point (point)) + (setq txt (buffer-substring beg end)) + (org-save-markers-in-region beg end) + (delete-region beg end) + (org-remove-empty-overlays-at beg) + (unless (= beg (point-min)) (org-flag-region (1- beg) beg nil 'outline)) + (unless (bobp) (org-flag-region (1- (point)) (point) nil 'outline)) + (and (not (bolp)) (looking-at "\n") (forward-char 1)) + (let ((bbb (point))) + (insert-before-markers txt) + (org-reinstall-markers-in-region bbb) + (move-marker ins-point bbb)) + (or (bolp) (insert "\n")) + (goto-char ins-point) + (org-skip-whitespace) + (move-marker ins-point nil) + (if folded + (org-flag-subtree t) + (org-show-entry) + (org-show-children)) + (org-clean-visibility-after-subtree-move) + ;; move back to the initial column we were at + (move-to-column col)))) (defvar org-subtree-clip "" "Clipboard for cut and paste of subtrees. @@ -8484,38 +7549,40 @@ If FORCE-STORE-MARKERS is non-nil, store the relative locations of some markers in the region, even if CUT is non-nil. This is useful if the caller implements cut-and-paste as copy-then-paste-then-cut." (interactive "p") - (let (beg end folded (beg0 (point))) - (if (called-interactively-p 'any) - (org-back-to-heading nil) ; take what looks like a subtree - (org-back-to-heading t)) ; take what is really there - (setq beg (point)) - (skip-chars-forward " \t\r\n") - (save-match-data - (if nosubtrees - (outline-next-heading) - (save-excursion (outline-end-of-heading) - (setq folded (org-invisible-p))) - (ignore-errors (org-forward-heading-same-level (1- n) t)) - (org-end-of-subtree t t))) - ;; Include the end of an inlinetask - (when (and (featurep 'org-inlinetask) - (looking-at-p (concat (org-inlinetask-outline-regexp) - "END[ \t]*$"))) - (end-of-line)) - (setq end (point)) - (goto-char beg0) - (when (> end beg) - (setq org-subtree-clip-folded folded) - (when (or cut force-store-markers) - (org-save-markers-in-region beg end)) - (if cut (kill-region beg end) (copy-region-as-kill beg end)) - (setq org-subtree-clip (current-kill 0)) - (message "%s: Subtree(s) with %d characters" - (if cut "Cut" "Copied") - (length org-subtree-clip))))) + (org-preserve-local-variables + (let (beg end folded (beg0 (point))) + (if (called-interactively-p 'any) + (org-back-to-heading nil) ; take what looks like a subtree + (org-back-to-heading t)) ; take what is really there + (setq beg (point)) + (skip-chars-forward " \t\r\n") + (save-match-data + (if nosubtrees + (outline-next-heading) + (save-excursion (outline-end-of-heading) + (setq folded (org-invisible-p))) + (ignore-errors (org-forward-heading-same-level (1- n) t)) + (org-end-of-subtree t t))) + ;; Include the end of an inlinetask + (when (and (featurep 'org-inlinetask) + (looking-at-p (concat (org-inlinetask-outline-regexp) + "END[ \t]*$"))) + (end-of-line)) + (setq end (point)) + (goto-char beg0) + (when (> end beg) + (setq org-subtree-clip-folded folded) + (when (or cut force-store-markers) + (org-save-markers-in-region beg end)) + (if cut (kill-region beg end) (copy-region-as-kill beg end)) + (setq org-subtree-clip (current-kill 0)) + (message "%s: Subtree(s) with %d characters" + (if cut "Cut" "Copied") + (length org-subtree-clip)))))) (defun org-paste-subtree (&optional level tree for-yank remove) "Paste the clipboard as a subtree, with modification of headline level. + The entire subtree is promoted or demoted in order to match a new headline level. @@ -8543,41 +7610,33 @@ When REMOVE is non-nil, remove the subtree from the clipboard." (interactive "P") (setq tree (or tree (and kill-ring (current-kill 0)))) (unless (org-kill-is-subtree-p tree) - (user-error "%s" - (substitute-command-keys - "The kill is not a (set of) tree(s) - please use \\[yank] to yank anyway"))) + (user-error + (substitute-command-keys + "The kill is not a (set of) tree(s). Use `\\[yank]' to yank anyway"))) (org-with-limited-levels (let* ((visp (not (org-invisible-p))) (txt tree) (old-level (if (string-match org-outline-regexp-bol txt) (- (match-end 0) (match-beginning 0) 1) -1)) - (force-level (cond (level (prefix-numeric-value level)) - ((and (looking-at "[ \t]*$") - (string-match - "^\\*+$" (buffer-substring - (point-at-bol) (point)))) - (- (match-end 0) (match-beginning 0))) - ((and (bolp) - (looking-at org-outline-regexp)) - (- (match-end 0) (point) 1)))) - (previous-level (save-excursion - (condition-case nil - (progn - (outline-previous-visible-heading 1) - (if (looking-at org-outline-regexp-bol) - (- (match-end 0) (match-beginning 0) 1) - 1)) - (error 1)))) - (next-level (save-excursion - (condition-case nil - (progn - (or (looking-at org-outline-regexp) - (outline-next-visible-heading 1)) - (if (looking-at org-outline-regexp-bol) - (- (match-end 0) (match-beginning 0) 1) - 1)) - (error 1)))) + (force-level + (cond + (level (prefix-numeric-value level)) + ;; When point is after the stars in an otherwise empty + ;; headline, use the number of stars as the forced level. + ((and (org-match-line "^\\*+[ \t]*$") + (not (eq ?* (char-after)))) + (org-outline-level)) + ((looking-at-p org-outline-regexp-bol) (org-outline-level)))) + (previous-level + (save-excursion + (org-previous-visible-heading 1) + (if (org-at-heading-p) (org-outline-level) 1))) + (next-level + (save-excursion + (if (org-at-heading-p) (org-outline-level) + (org-next-visible-heading 1) + (if (org-at-heading-p) (org-outline-level) 1)))) (new-level (or force-level (max previous-level next-level))) (shift (if (or (= old-level -1) (= new-level -1) @@ -8585,16 +7644,19 @@ When REMOVE is non-nil, remove the subtree from the clipboard." 0 (- new-level old-level))) (delta (if (> shift 0) -1 1)) - (func (if (> shift 0) 'org-demote 'org-promote)) + (func (if (> shift 0) #'org-demote #'org-promote)) (org-odd-levels-only nil) beg end newend) - ;; Remove the forced level indicator - (when force-level - (delete-region (point-at-bol) (point))) - ;; Paste - (beginning-of-line (if (bolp) 1 2)) + ;; Remove the forced level indicator. + (when (and force-level (not level)) + (delete-region (line-beginning-position) (point))) + ;; Paste before the next visible heading or at end of buffer, + ;; unless point is at the beginning of a headline. + (unless (and (bolp) (org-at-heading-p)) + (org-next-visible-heading 1) + (unless (bolp) (insert "\n"))) (setq beg (point)) - (and (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt)) + (when (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt)) (insert-before-markers txt) (unless (string-suffix-p "\n" txt) (insert "\n")) (setq newend (point)) @@ -8605,7 +7667,7 @@ When REMOVE is non-nil, remove the subtree from the clipboard." (setq beg (point)) (when (and (org-invisible-p) visp) (save-excursion (outline-show-heading))) - ;; Shift if necessary + ;; Shift if necessary. (unless (= shift 0) (save-restriction (narrow-to-region beg end) @@ -8614,16 +7676,16 @@ When REMOVE is non-nil, remove the subtree from the clipboard." (setq shift (+ delta shift))) (goto-char (point-min)) (setq newend (point-max)))) - (when (or (called-interactively-p 'interactive) for-yank) + (when (or for-yank (called-interactively-p 'interactive)) (message "Clipboard pasted as level %d subtree" new-level)) (when (and (not for-yank) ; in this case, org-yank will decide about folding kill-ring - (eq org-subtree-clip (current-kill 0)) + (equal org-subtree-clip (current-kill 0)) org-subtree-clip-folded) ;; The tree was folded before it was killed/copied - (outline-hide-subtree)) - (and for-yank (goto-char newend)) - (and remove (setq kill-ring (cdr kill-ring)))))) + (org-flag-subtree t)) + (when for-yank (goto-char newend)) + (when remove (pop kill-ring))))) (defun org-kill-is-subtree-p (&optional txt) "Check if the current kill is an outline subtree, or a set of trees. @@ -8695,6 +7757,13 @@ If yes, remember the marker and the distance to BEG." (when (and (org-at-heading-p) (not (eobp))) (backward-char 1)) (point))))))) +(defun org-toggle-narrow-to-subtree () + "Narrow to the subtree at point or widen a narrowed buffer." + (interactive) + (if (buffer-narrowed-p) + (widen) + (org-narrow-to-subtree))) + (defun org-narrow-to-block () "Narrow buffer to the current block." (interactive) @@ -8756,7 +7825,7 @@ with the original repeater." ""))) ;No time shift (doshift (and (org-string-nw-p shift) - (or (string-match "\\`[ \t]*\\+?\\([0-9]+\\)\\([dwmy]\\)[ \t]*\\'" + (or (string-match "\\`[ \t]*\\([\\+\\-]?[0-9]+\\)\\([dwmy]\\)[ \t]*\\'" shift) (user-error "Invalid shift specification %s" shift))))) (goto-char end-of-tree) @@ -8933,7 +8002,7 @@ function is being called interactively." (setq end (point-max)) (setq what "top-level") (goto-char start) - (outline-show-all))) + (org-show-all '(headings blocks)))) (setq beg (point)) (when (>= beg end) (goto-char start) (user-error "Nothing to sort")) @@ -8982,95 +8051,95 @@ function is being called interactively." (when (and (eq (org-clock-is-active) (current-buffer)) (<= start (marker-position org-clock-marker)) (>= end (marker-position org-clock-marker))) - (org-with-silent-modifications - (put-text-property (1- org-clock-marker) org-clock-marker - :org-clock-marker-backup t)) + (with-silent-modifications + (put-text-property (1- org-clock-marker) org-clock-marker + :org-clock-marker-backup t)) t)) (dcst (downcase sorting-type)) (case-fold-search nil) (now (current-time))) - (sort-subr - (/= dcst sorting-type) - ;; This function moves to the beginning character of the "record" to - ;; be sorted. - (lambda nil - (if (re-search-forward re nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max)))) - ;; This function moves to the last character of the "record" being - ;; sorted. - (lambda nil - (save-match-data - (condition-case nil - (outline-forward-same-level 1) - (error - (goto-char (point-max)))))) - ;; This function returns the value that gets sorted against. - (lambda nil - (cond - ((= dcst ?n) - (if (looking-at org-complex-heading-regexp) - (string-to-number (org-sort-remove-invisible (match-string 4))) - nil)) - ((= dcst ?a) - (if (looking-at org-complex-heading-regexp) - (funcall case-func (org-sort-remove-invisible (match-string 4))) - nil)) - ((= dcst ?k) - (or (get-text-property (point) :org-clock-minutes) 0)) - ((= dcst ?t) - (let ((end (save-excursion (outline-next-heading) (point)))) - (if (or (re-search-forward org-ts-regexp end t) - (re-search-forward org-ts-regexp-both end t)) - (org-time-string-to-seconds (match-string 0)) - (float-time now)))) - ((= dcst ?c) - (let ((end (save-excursion (outline-next-heading) (point)))) - (if (re-search-forward - (concat "^[ \t]*\\[" org-ts-regexp1 "\\]") - end t) - (org-time-string-to-seconds (match-string 0)) - (float-time now)))) - ((= dcst ?s) - (let ((end (save-excursion (outline-next-heading) (point)))) - (if (re-search-forward org-scheduled-time-regexp end t) - (org-time-string-to-seconds (match-string 1)) - (float-time now)))) - ((= dcst ?d) - (let ((end (save-excursion (outline-next-heading) (point)))) - (if (re-search-forward org-deadline-time-regexp end t) - (org-time-string-to-seconds (match-string 1)) - (float-time now)))) - ((= dcst ?p) - (if (re-search-forward org-priority-regexp (point-at-eol) t) - (string-to-char (match-string 2)) - org-default-priority)) - ((= dcst ?r) - (or (org-entry-get nil property) "")) - ((= dcst ?o) - (when (looking-at org-complex-heading-regexp) - (let* ((m (match-string 2)) - (s (if (member m org-done-keywords) '- '+))) - (- 99 (funcall s (length (member m org-todo-keywords-1))))))) - ((= dcst ?f) - (if getkey-func - (progn - (setq tmp (funcall getkey-func)) - (when (stringp tmp) (setq tmp (funcall case-func tmp))) - tmp) - (error "Invalid key function `%s'" getkey-func))) - (t (error "Invalid sorting type `%c'" sorting-type)))) - nil - (cond - ((= dcst ?a) 'string<) - ((= dcst ?f) - (or compare-func - (and interactive? - (org-read-function - (concat "Function for comparing keys " - "(empty for default `sort-subr' predicate): ") - 'allow-empty)))) - ((member dcst '(?p ?t ?s ?d ?c ?k)) '<))) + (org-preserve-local-variables + (sort-subr + (/= dcst sorting-type) + ;; This function moves to the beginning character of the + ;; "record" to be sorted. + (lambda nil + (if (re-search-forward re nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max)))) + ;; This function moves to the last character of the "record" being + ;; sorted. + (lambda nil + (save-match-data + (condition-case nil + (outline-forward-same-level 1) + (error + (goto-char (point-max)))))) + ;; This function returns the value that gets sorted against. + (lambda () + (cond + ((= dcst ?n) + (string-to-number + (org-sort-remove-invisible (org-get-heading t t t t)))) + ((= dcst ?a) + (funcall case-func + (org-sort-remove-invisible (org-get-heading t t t t)))) + ((= dcst ?k) + (or (get-text-property (point) :org-clock-minutes) 0)) + ((= dcst ?t) + (let ((end (save-excursion (outline-next-heading) (point)))) + (if (or (re-search-forward org-ts-regexp end t) + (re-search-forward org-ts-regexp-both end t)) + (org-time-string-to-seconds (match-string 0)) + (float-time now)))) + ((= dcst ?c) + (let ((end (save-excursion (outline-next-heading) (point)))) + (if (re-search-forward + (concat "^[ \t]*\\[" org-ts-regexp1 "\\]") + end t) + (org-time-string-to-seconds (match-string 0)) + (float-time now)))) + ((= dcst ?s) + (let ((end (save-excursion (outline-next-heading) (point)))) + (if (re-search-forward org-scheduled-time-regexp end t) + (org-time-string-to-seconds (match-string 1)) + (float-time now)))) + ((= dcst ?d) + (let ((end (save-excursion (outline-next-heading) (point)))) + (if (re-search-forward org-deadline-time-regexp end t) + (org-time-string-to-seconds (match-string 1)) + (float-time now)))) + ((= dcst ?p) + (if (re-search-forward org-priority-regexp (point-at-eol) t) + (string-to-char (match-string 2)) + org-default-priority)) + ((= dcst ?r) + (or (org-entry-get nil property) "")) + ((= dcst ?o) + (when (looking-at org-complex-heading-regexp) + (let* ((m (match-string 2)) + (s (if (member m org-done-keywords) '- '+))) + (- 99 (funcall s (length (member m org-todo-keywords-1))))))) + ((= dcst ?f) + (if getkey-func + (progn + (setq tmp (funcall getkey-func)) + (when (stringp tmp) (setq tmp (funcall case-func tmp))) + tmp) + (error "Invalid key function `%s'" getkey-func))) + (t (error "Invalid sorting type `%c'" sorting-type)))) + nil + (cond + ((= dcst ?a) 'org-string-collate-lessp) + ((= dcst ?f) + (or compare-func + (and interactive? + (org-read-function + (concat "Function for comparing keys " + "(empty for default `sort-subr' predicate): ") + 'allow-empty)))) + ((member dcst '(?p ?t ?s ?d ?c ?k)) '<)))) + (org-cycle-hide-drawers 'all) (when restore-clock? (move-marker org-clock-marker (1+ (next-single-property-change @@ -9080,272 +8149,6 @@ function is being called interactively." (run-hooks 'org-after-sorting-entries-or-items-hook) (message "Sorting entries...done"))) -;;; The orgstruct minor mode - -;; Define a minor mode which can be used in other modes in order to -;; integrate the Org mode structure editing commands. - -;; This is really a hack, because the Org mode structure commands use -;; keys which normally belong to the major mode. Here is how it -;; works: The minor mode defines all the keys necessary to operate the -;; structure commands, but wraps the commands into a function which -;; tests if the cursor is currently at a headline or a plain list -;; item. If that is the case, the structure command is used, -;; temporarily setting many Org mode variables like regular -;; expressions for filling etc. However, when any of those keys is -;; used at a different location, function uses `key-binding' to look -;; up if the key has an associated command in another currently active -;; keymap (minor modes, major mode, global), and executes that -;; command. There might be problems if any of the keys is otherwise -;; used as a prefix key. - -(defcustom orgstruct-heading-prefix-regexp "" - "Regexp that matches the custom prefix of Org headlines in -orgstruct(++)-mode." - :group 'org - :version "26.1" - :package-version '(Org . "8.3") - :type 'regexp) -;;;###autoload(put 'orgstruct-heading-prefix-regexp 'safe-local-variable 'stringp) - -(defcustom orgstruct-setup-hook nil - "Hook run after orgstruct-mode-map is filled." - :group 'org - :version "24.4" - :package-version '(Org . "8.0") - :type 'hook) - -(defvar orgstruct-initialized nil) - -(defvar org-local-vars nil - "List of local variables, for use by `orgstruct-mode'.") - -;;;###autoload -(define-minor-mode orgstruct-mode - "Toggle the minor mode `orgstruct-mode'. -This mode is for using Org mode structure commands in other -modes. The following keys behave as if Org mode were active, if -the cursor is on a headline, or on a plain list item (both as -defined by Org mode)." - nil " OrgStruct" (make-sparse-keymap) - (funcall (if orgstruct-mode - 'add-to-invisibility-spec - 'remove-from-invisibility-spec) - '(outline . t)) - (when orgstruct-mode - (org-load-modules-maybe) - (unless orgstruct-initialized - (orgstruct-setup) - (setq orgstruct-initialized t)))) - -;;;###autoload -(defun turn-on-orgstruct () - "Unconditionally turn on `orgstruct-mode'." - (orgstruct-mode 1)) - -(defvar-local orgstruct-is-++ nil - "Is `orgstruct-mode' in ++ version in the current-buffer?") -(defvar-local org-fb-vars nil) -(defun orgstruct++-mode (&optional arg) - "Toggle `orgstruct-mode', the enhanced version of it. -In addition to setting orgstruct-mode, this also exports all -indentation and autofilling variables from Org mode into the -buffer. It will also recognize item context in multiline items." - (interactive "P") - (setq arg (prefix-numeric-value (or arg (if orgstruct-mode -1 1)))) - (if (< arg 1) - (progn (orgstruct-mode -1) - (dolist (v org-fb-vars) - (set (make-local-variable (car v)) - (if (eq (car-safe (cadr v)) 'quote) - (cl-cadadr v) - (nth 1 v))))) - (orgstruct-mode 1) - (setq org-fb-vars nil) - (unless org-local-vars - (setq org-local-vars (org-get-local-variables))) - (let (var val) - (dolist (x org-local-vars) - (when (string-match - "^\\(paragraph-\\|auto-fill\\|normal-auto-fill\\|fill-paragraph\ -\\|fill-prefix\\|indent-\\)" - (symbol-name (car x))) - (setq var (car x) val (nth 1 x)) - (push (list var `(quote ,(eval var))) org-fb-vars) - (set (make-local-variable var) - (if (eq (car-safe val) 'quote) (nth 1 val) val)))) - (setq-local orgstruct-is-++ t)))) - -;;;###autoload -(defun turn-on-orgstruct++ () - "Unconditionally turn on `orgstruct++-mode'." - (orgstruct++-mode 1)) - -(defun orgstruct-error () - "Error when there is no default binding for a structure key." - (interactive) - (funcall (if (fboundp 'user-error) - 'user-error - 'error) - "This key has no function outside structure elements")) - -(defun orgstruct-setup () - "Setup orgstruct keymap." - (dolist (cell '((org-demote . t) - (org-metaleft . t) - (org-metaright . t) - (org-promote . t) - (org-shiftmetaleft . t) - (org-shiftmetaright . t) - org-backward-element - org-backward-heading-same-level - org-ctrl-c-ret - org-ctrl-c-minus - org-ctrl-c-star - org-cycle - org-force-cycle-archived - org-forward-heading-same-level - org-insert-heading - org-insert-heading-respect-content - org-kill-note-or-show-branches - org-mark-subtree - org-meta-return - org-metadown - org-metaup - org-narrow-to-subtree - org-promote-subtree - org-reveal - org-shiftdown - org-shiftleft - org-shiftmetadown - org-shiftmetaup - org-shiftright - org-shifttab - org-shifttab - org-shiftup - org-show-children - org-show-subtree - org-sort - org-up-element - outline-demote - outline-next-visible-heading - outline-previous-visible-heading - outline-promote - outline-up-heading)) - (let ((f (or (car-safe cell) cell)) - (disable-when-heading-prefix (cdr-safe cell))) - (when (fboundp f) - (let ((new-bindings)) - (dolist (binding (nconc (where-is-internal f org-mode-map) - (where-is-internal f outline-mode-map))) - (push binding new-bindings) - ;; TODO use local-function-key-map - (dolist (rep '(("<tab>" . "TAB") - ("<return>" . "RET") - ("<escape>" . "ESC") - ("<delete>" . "DEL"))) - (setq binding (read-kbd-macro - (let ((case-fold-search)) - (replace-regexp-in-string - (regexp-quote (cdr rep)) - (car rep) - (key-description binding))))) - (cl-pushnew binding new-bindings :test 'equal))) - (dolist (binding new-bindings) - (let ((key (lookup-key orgstruct-mode-map binding))) - (when (or (not key) (numberp key)) - (ignore-errors - (org-defkey orgstruct-mode-map - binding - (orgstruct-make-binding - f binding disable-when-heading-prefix)))))))))) - (run-hooks 'orgstruct-setup-hook)) - -(defun orgstruct-make-binding (fun key disable-when-heading-prefix) - "Create a function for binding in the structure minor mode. -FUN is the command to call inside a table. KEY is the key that -should be checked in for a command to execute outside of tables. -Non-nil `disable-when-heading-prefix' means to disable the command -if `orgstruct-heading-prefix-regexp' is not empty." - (let ((name (concat "orgstruct-hijacker-" (symbol-name fun)))) - (let ((nname name) - (i 0)) - (while (fboundp (intern nname)) - (setq nname (format "%s-%d" name (setq i (1+ i))))) - (setq name (intern nname))) - (eval - (let ((bindings '((org-heading-regexp - (concat "^" - orgstruct-heading-prefix-regexp - "\\(\\*+\\)\\(?: +\\(.*?\\)\\)?[ ]*$")) - (org-outline-regexp - (concat orgstruct-heading-prefix-regexp "\\*+ ")) - (org-outline-regexp-bol - (concat "^" org-outline-regexp)) - (outline-regexp org-outline-regexp) - (outline-heading-end-regexp "\n") - (outline-level 'org-outline-level) - (outline-heading-alist)))) - `(defun ,name (arg) - ,(concat "In Structure, run `" (symbol-name fun) "'.\n" - "Outside of structure, run the binding of `" - (key-description key) "'." - (when disable-when-heading-prefix - (concat - "\nIf `orgstruct-heading-prefix-regexp' is not empty, this command will always fall\n" - "back to the default binding due to limitations of Org's implementation of\n" - "`" (symbol-name fun) "'."))) - (interactive "p") - (let* ((disable - ,(and disable-when-heading-prefix - '(not (string= orgstruct-heading-prefix-regexp "")))) - (fallback - (or disable - (not - (let* ,bindings - (org-context-p 'headline 'item - ,(when (memq fun - '(org-insert-heading - org-insert-heading-respect-content - org-meta-return)) - '(when orgstruct-is-++ - 'item-body)))))))) - (if fallback - (let* ((orgstruct-mode) - (binding - (let ((key ,key)) - (catch 'exit - (dolist - (rep - '(nil - ("<\\([^>]*\\)tab>" . "\\1TAB") - ("<\\([^>]*\\)return>" . "\\1RET") - ("<\\([^>]*\\)escape>" . "\\1ESC") - ("<\\([^>]*\\)delete>" . "\\1DEL")) - nil) - (when rep - (setq key (read-kbd-macro - (let ((case-fold-search)) - (replace-regexp-in-string - (car rep) - (cdr rep) - (key-description key)))))) - (when (key-binding key) - (throw 'exit (key-binding key)))))))) - (if (keymapp binding) - (org-set-transient-map binding) - (let ((func (or binding - (unless disable - 'orgstruct-error)))) - (when func - (call-interactively func))))) - (org-run-like-in-org-mode - (lambda () - (interactive) - (let* ,bindings - (call-interactively ',fun))))))))) - name)) - (defun org-contextualize-keys (alist contexts) "Return valid elements in ALIST depending on CONTEXTS. @@ -9423,20 +8226,11 @@ definitions." (push r res)))) (delete-dups (delq nil res)))) -(defun org-context-p (&rest contexts) - "Check if local context is any of CONTEXTS. -Possible values in the list of contexts are `table', `headline', and `item'." - (let ((pos (point))) - (goto-char (point-at-bol)) - (prog1 (or (and (memq 'table contexts) - (looking-at "[ \t]*|")) - (and (memq 'headline contexts) - (looking-at org-outline-regexp)) - (and (memq 'item contexts) - (looking-at "[ \t]*\\([-+*] \\|[0-9]+[.)] \\)")) - (and (memq 'item-body contexts) - (org-in-item-p))) - (goto-char pos)))) +;; Defined to provide a value for defcustom, since there is no +;; string-collate-greaterp in Emacs. +(defun org-string-collate-greaterp (s1 s2) + "Return non-nil if S1 is greater than S2 in collation order." + (not (org-string-collate-lessp s1 s2))) ;;;###autoload (defun org-run-like-in-org-mode (cmd) @@ -9445,10 +8239,8 @@ This will temporarily bind local variables that are typically bound in Org mode to the values they have in Org mode, and then interactively call CMD." (org-load-modules-maybe) - (unless org-local-vars - (setq org-local-vars (org-get-local-variables))) (let (binds) - (dolist (var org-local-vars) + (dolist (var (org-get-local-variables)) (when (or (not (boundp (car var))) (eq (symbol-value (car var)) (default-value (car var)))) @@ -9478,16 +8270,16 @@ the value of the drawer property." (inherit? (org-property-inherit-p dprop)) (property-re (org-re-property (concat (regexp-quote dprop) "\\+?") t)) (global (and inherit? (org--property-global-value dprop nil)))) - (org-with-silent-modifications - (org-with-point-at 1 - ;; Set global values (e.g., values defined through - ;; "#+PROPERTY:" keywords) to the whole buffer. - (when global (put-text-property (point-min) (point-max) tprop global)) - ;; Set local values. - (while (re-search-forward property-re nil t) - (when (org-at-property-p) - (org-refresh-property tprop (org-entry-get (point) dprop) inherit?)) - (outline-next-heading)))))) + (with-silent-modifications + (org-with-point-at 1 + ;; Set global values (e.g., values defined through + ;; "#+PROPERTY:" keywords) to the whole buffer. + (when global (put-text-property (point-min) (point-max) tprop global)) + ;; Set local values. + (while (re-search-forward property-re nil t) + (when (org-at-property-p) + (org-refresh-property tprop (org-entry-get (point) dprop) inherit?)) + (outline-next-heading)))))) (defun org-refresh-property (tprop p &optional inherit) "Refresh the buffer text property TPROP from the drawer property P. @@ -9519,49 +8311,49 @@ sub-tree if optional argument INHERIT is non-nil." "???")) ((symbolp org-category) (symbol-name org-category)) (t org-category)))) - (org-with-silent-modifications - (org-with-wide-buffer - ;; Set buffer-wide category. Search last #+CATEGORY keyword. - ;; This is the default category for the buffer. If none is - ;; found, fall-back to `org-category' or buffer file name. - (put-text-property - (point-min) (point-max) - 'org-category - (catch 'buffer-category - (goto-char (point-max)) - (while (re-search-backward "^[ \t]*#\\+CATEGORY:" (point-min) t) - (let ((element (org-element-at-point))) - (when (eq (org-element-type element) 'keyword) - (throw 'buffer-category - (org-element-property :value element))))) - default-category)) - ;; Set sub-tree specific categories. - (goto-char (point-min)) - (let ((regexp (org-re-property "CATEGORY"))) - (while (re-search-forward regexp nil t) - (let ((value (match-string-no-properties 3))) - (when (org-at-property-p) - (put-text-property - (save-excursion (org-back-to-heading t) (point)) - (save-excursion (org-end-of-subtree t t) (point)) - 'org-category - value))))))))) + (with-silent-modifications + (org-with-wide-buffer + ;; Set buffer-wide category. Search last #+CATEGORY keyword. + ;; This is the default category for the buffer. If none is + ;; found, fall-back to `org-category' or buffer file name. + (put-text-property + (point-min) (point-max) + 'org-category + (catch 'buffer-category + (goto-char (point-max)) + (while (re-search-backward "^[ \t]*#\\+CATEGORY:" (point-min) t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'keyword) + (throw 'buffer-category + (org-element-property :value element))))) + default-category)) + ;; Set sub-tree specific categories. + (goto-char (point-min)) + (let ((regexp (org-re-property "CATEGORY"))) + (while (re-search-forward regexp nil t) + (let ((value (match-string-no-properties 3))) + (when (org-at-property-p) + (put-text-property + (save-excursion (org-back-to-heading t) (point)) + (save-excursion (org-end-of-subtree t t) (point)) + 'org-category + value))))))))) (defun org-refresh-stats-properties () "Refresh stats text properties in the buffer." - (org-with-silent-modifications - (org-with-point-at 1 - (let ((regexp (concat org-outline-regexp-bol - ".*\\[\\([0-9]*\\)\\(?:%\\|/\\([0-9]*\\)\\)\\]"))) - (while (re-search-forward regexp nil t) - (let* ((numerator (string-to-number (match-string 1))) - (denominator (and (match-end 2) - (string-to-number (match-string 2)))) - (stats (cond ((not denominator) numerator) ;percent - ((= denominator 0) 0) - (t (/ (* numerator 100) denominator))))) - (put-text-property (point) (progn (org-end-of-subtree t t) (point)) - 'org-stats stats))))))) + (with-silent-modifications + (org-with-point-at 1 + (let ((regexp (concat org-outline-regexp-bol + ".*\\[\\([0-9]*\\)\\(?:%\\|/\\([0-9]*\\)\\)\\]"))) + (while (re-search-forward regexp nil t) + (let* ((numerator (string-to-number (match-string 1))) + (denominator (and (match-end 2) + (string-to-number (match-string 2)))) + (stats (cond ((not denominator) numerator) ;percent + ((= denominator 0) 0) + (t (/ (* numerator 100) denominator))))) + (put-text-property (point) (progn (org-end-of-subtree t t) (point)) + 'org-stats stats))))))) (defun org-refresh-effort-properties () "Refresh effort properties." @@ -9570,905 +8362,6 @@ sub-tree if optional argument INHERIT is non-nil." '((effort . identity) (effort-minutes . org-duration-to-minutes)))) -;;;; Link Stuff - -;;; Link abbreviations - -(defun org-link-expand-abbrev (link) - "Apply replacements as defined in `org-link-abbrev-alist'." - (if (string-match "^\\([^:]*\\)\\(::?\\(.*\\)\\)?$" link) - (let* ((key (match-string 1 link)) - (as (or (assoc key org-link-abbrev-alist-local) - (assoc key org-link-abbrev-alist))) - (tag (and (match-end 2) (match-string 3 link))) - rpl) - (if (not as) - link - (setq rpl (cdr as)) - (cond - ((symbolp rpl) (funcall rpl tag)) - ((string-match "%(\\([^)]+\\))" rpl) - (replace-match - (save-match-data - (funcall (intern-soft (match-string 1 rpl)) tag)) t t rpl)) - ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) - ((string-match "%h" rpl) - (replace-match (url-hexify-string (or tag "")) t t rpl)) - (t (concat rpl tag))))) - link)) - -;;; Storing and inserting links - -(defvar org-insert-link-history nil - "Minibuffer history for links inserted with `org-insert-link'.") - -(defvar org-stored-links nil - "Contains the links stored with `org-store-link'.") - -(defvar org-store-link-plist nil - "Plist with info about the most recently link created with `org-store-link'.") - -(defun org-store-link-functions () - "Return a list of functions that are called to create and store a link. -The functions defined in the :store property of -`org-link-parameters'. - -Each function will be called in turn until one returns a non-nil -value. Each function should check if it is responsible for -creating this link (for example by looking at the major mode). -If not, it must exit and return nil. If yes, it should return -a non-nil value after calling `org-store-link-props' with a list -of properties and values. Special properties are: - -:type The link prefix, like \"http\". This must be given. -:link The link, like \"http://www.astro.uva.nl/~dominik\". - This is obligatory as well. -:description Optional default description for the second pair - of brackets in an Org mode link. The user can still change - this when inserting this link into an Org mode buffer. - -In addition to these, any additional properties can be specified -and then used in capture templates." - (cl-loop for link in org-link-parameters - with store-func - do (setq store-func (org-link-get-parameter (car link) :store)) - if store-func - collect store-func)) - -(defvar org-agenda-buffer-name) ; Defined in org-agenda.el -(defvar org-id-link-to-org-use-id) ; Defined in org-id.el - -;;;###autoload -(defun org-store-link (arg) - "Store an org-link to the current location. -\\<org-mode-map> -This link is added to `org-stored-links' and can later be inserted -into an Org buffer with `org-insert-link' (`\\[org-insert-link]'). - -For some link types, a `\\[universal-argument]' prefix ARG is interpreted. \ -A single -`\\[universal-argument]' negates `org-context-in-file-links' for file links or -`org-gnus-prefer-web-links' for links to Usenet articles. - -A `\\[universal-argument] \\[universal-argument]' prefix ARG forces \ -skipping storing functions that are not -part of Org core. - -A `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \ -prefix ARG forces storing a link for each line in the -active region." - (interactive "P") - (org-load-modules-maybe) - (if (and (equal arg '(64)) (org-region-active-p)) - (save-excursion - (let ((end (region-end))) - (goto-char (region-beginning)) - (set-mark (point)) - (while (< (point-at-eol) end) - (move-end-of-line 1) (activate-mark) - (let (current-prefix-arg) - (call-interactively 'org-store-link)) - (move-beginning-of-line 2) - (set-mark (point))))) - (setq org-store-link-plist nil) - (let (link cpltxt desc description search txt custom-id agenda-link) - (cond - ;; Store a link using an external link type, if any function is - ;; available. If more than one can generate a link from current - ;; location, ask which one to use. - ((and (not (equal arg '(16))) - (let ((results-alist nil)) - (dolist (f (org-store-link-functions)) - (when (funcall f) - ;; XXX: return value is not link's plist, so we - ;; store the new value before it is modified. It - ;; would be cleaner to ask store link functions to - ;; return the plist instead. - (push (cons f (copy-sequence org-store-link-plist)) - results-alist))) - (pcase results-alist - (`nil nil) - (`((,_ . ,_)) t) ;single choice: nothing to do - (`((,name . ,_) . ,_) - ;; Reinstate link plist associated to the chosen - ;; function. - (apply #'org-store-link-props - (cdr (assoc-string - (completing-read - "Which function for creating the link? " - (mapcar #'car results-alist) - nil t (symbol-name name)) - results-alist))) - t)))) - (setq link (plist-get org-store-link-plist :link)) - (setq desc (or (plist-get org-store-link-plist :description) - link))) - - ;; Store a link from a source code buffer. - ((org-src-edit-buffer-p) - (let ((coderef-format (org-src-coderef-format))) - (cond ((save-excursion - (beginning-of-line) - (looking-at (org-src-coderef-regexp coderef-format))) - (setq link (format "(%s)" (match-string-no-properties 3)))) - ((called-interactively-p 'any) - (let ((label (read-string "Code line label: "))) - (end-of-line) - (setq link (format coderef-format label)) - (let ((gc (- 79 (length link)))) - (if (< (current-column) gc) - (org-move-to-column gc t) - (insert " "))) - (insert link) - (setq link (concat "(" label ")")) - (setq desc nil))) - (t (setq link nil))))) - - ;; We are in the agenda, link to referenced location - ((equal (bound-and-true-p org-agenda-buffer-name) (buffer-name)) - (let ((m (or (get-text-property (point) 'org-hd-marker) - (get-text-property (point) 'org-marker)))) - (when m - (org-with-point-at m - (setq agenda-link - (if (called-interactively-p 'any) - (call-interactively 'org-store-link) - (org-store-link nil))))))) - - ((eq major-mode 'calendar-mode) - (let ((cd (calendar-cursor-to-date))) - (setq link - (format-time-string - (car org-time-stamp-formats) - (encode-time 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd)))) - (org-store-link-props :type "calendar" :date cd))) - - ((eq major-mode 'help-mode) - (setq link (concat "help:" (save-excursion - (goto-char (point-min)) - (looking-at "^[^ ]+") - (match-string 0)))) - (org-store-link-props :type "help")) - - ((eq major-mode 'w3-mode) - (setq cpltxt (if (and (buffer-name) - (not (string-match "Untitled" (buffer-name)))) - (buffer-name) - (url-view-url t)) - link (url-view-url t)) - (org-store-link-props :type "w3" :url (url-view-url t))) - - ((eq major-mode 'image-mode) - (setq cpltxt (concat "file:" - (abbreviate-file-name buffer-file-name)) - link cpltxt) - (org-store-link-props :type "image" :file buffer-file-name)) - - ;; In dired, store a link to the file of the current line - ((derived-mode-p 'dired-mode) - (let ((file (dired-get-filename nil t))) - (setq file (if file - (abbreviate-file-name - (expand-file-name (dired-get-filename nil t))) - ;; otherwise, no file so use current directory. - default-directory)) - (setq cpltxt (concat "file:" file) - link cpltxt))) - - ((setq search (run-hook-with-args-until-success - 'org-create-file-search-functions)) - (setq link (concat "file:" (abbreviate-file-name buffer-file-name) - "::" search)) - (setq cpltxt (or description link))) - - ((and (buffer-file-name (buffer-base-buffer)) (derived-mode-p 'org-mode)) - (org-with-limited-levels - (setq custom-id (org-entry-get nil "CUSTOM_ID")) - (cond - ;; Store a link using the target at point - ((org-in-regexp "[^<]<<\\([^<>]+\\)>>[^>]" 1) - (setq cpltxt - (concat "file:" - (abbreviate-file-name - (buffer-file-name (buffer-base-buffer))) - "::" (match-string 1)) - link cpltxt)) - ((and (featurep 'org-id) - (or (eq org-id-link-to-org-use-id t) - (and (called-interactively-p 'any) - (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 custom-id)))) - (and org-id-link-to-org-use-id (org-entry-get nil "ID")))) - ;; Store a link using the ID at point - (setq link (condition-case nil - (prog1 (org-id-store-link) - (setq desc (or (plist-get org-store-link-plist - :description) - ""))) - (error - ;; Probably before first headline, link only to file - (concat "file:" - (abbreviate-file-name - (buffer-file-name (buffer-base-buffer)))))))) - (t - ;; Just link to current headline - (setq cpltxt (concat "file:" - (abbreviate-file-name - (buffer-file-name (buffer-base-buffer))))) - ;; Add a context search string - (when (org-xor org-context-in-file-links - (equal arg '(4))) - (let* ((element (org-element-at-point)) - (name (org-element-property :name element))) - (setq txt (cond - ((org-at-heading-p) nil) - (name) - ((org-region-active-p) - (buffer-substring (region-beginning) (region-end))))) - (when (or (null txt) (string-match "\\S-" txt)) - (setq cpltxt - (concat cpltxt "::" - (condition-case nil - (org-make-org-heading-search-string txt) - (error ""))) - desc (or name - (nth 4 (ignore-errors (org-heading-components))) - "NONE"))))) - (when (string-match "::\\'" cpltxt) - (setq cpltxt (substring cpltxt 0 -2))) - (setq link cpltxt))))) - - ((buffer-file-name (buffer-base-buffer)) - ;; Just link to this file here. - (setq cpltxt (concat "file:" - (abbreviate-file-name - (buffer-file-name (buffer-base-buffer))))) - ;; Add a context string. - (when (org-xor org-context-in-file-links - (equal arg '(4))) - (setq txt (if (org-region-active-p) - (buffer-substring (region-beginning) (region-end)) - (buffer-substring (point-at-bol) (point-at-eol)))) - ;; Only use search option if there is some text. - (when (string-match "\\S-" txt) - (setq cpltxt - (concat cpltxt "::" (org-make-org-heading-search-string txt)) - desc "NONE"))) - (setq link cpltxt)) - - ((called-interactively-p 'interactive) - (user-error "No method for storing a link from this buffer")) - - (t (setq link nil))) - - ;; We're done setting link and desc, clean up - (when (consp link) (setq cpltxt (car link) link (cdr link))) - (setq link (or link cpltxt) - desc (or desc cpltxt)) - (cond ((not desc)) - ((equal desc "NONE") (setq desc nil)) - (t (setq desc - (replace-regexp-in-string - org-bracket-link-analytic-regexp - (lambda (m) (or (match-string 5 m) (match-string 3 m))) - desc)))) - ;; Return the link - (if (not (and (or (called-interactively-p 'any) - executing-kbd-macro) - link)) - (or agenda-link (and link (org-make-link-string link desc))) - (push (list link desc) org-stored-links) - (message "Stored: %s" (or desc link)) - (when custom-id - (setq link (concat "file:" (abbreviate-file-name - (buffer-file-name)) "::#" custom-id)) - (push (list link desc) org-stored-links)) - (car org-stored-links))))) - -(defun org-store-link-props (&rest plist) - "Store link properties. -The properties are pre-processed by extracting names, addresses -and dates." - (let ((x (plist-get plist :from))) - (when x - (let ((adr (mail-extract-address-components x))) - (setq plist (plist-put plist :fromname (car adr))) - (setq plist (plist-put plist :fromaddress (nth 1 adr)))))) - (let ((x (plist-get plist :to))) - (when x - (let ((adr (mail-extract-address-components x))) - (setq plist (plist-put plist :toname (car adr))) - (setq plist (plist-put plist :toaddress (nth 1 adr)))))) - (let ((x (ignore-errors (date-to-time (plist-get plist :date))))) - (when x - (setq plist (plist-put plist :date-timestamp - (format-time-string - (org-time-stamp-format t) x))) - (setq plist (plist-put plist :date-timestamp-inactive - (format-time-string - (org-time-stamp-format t t) x))))) - (let ((from (plist-get plist :from)) - (to (plist-get plist :to))) - (when (and from to org-from-is-user-regexp) - (setq plist - (plist-put plist :fromto - (if (string-match org-from-is-user-regexp from) - (concat "to %t") - (concat "from %f")))))) - (setq org-store-link-plist plist)) - -(defun org-add-link-props (&rest plist) - "Add these properties to the link property list." - (let (key value) - (while plist - (setq key (pop plist) value (pop plist)) - (setq org-store-link-plist - (plist-put org-store-link-plist key value))))) - -(defun org-email-link-description (&optional fmt) - "Return the description part of an email link. -This takes information from `org-store-link-plist' and formats it -according to FMT (default from `org-email-link-description-format')." - (setq fmt (or fmt org-email-link-description-format)) - (let* ((p org-store-link-plist) - (to (plist-get p :toaddress)) - (from (plist-get p :fromaddress)) - (table - (list - (cons "%c" (plist-get p :fromto)) - (cons "%F" (plist-get p :from)) - (cons "%f" (or (plist-get p :fromname) (plist-get p :fromaddress) "?")) - (cons "%T" (plist-get p :to)) - (cons "%t" (or (plist-get p :toname) (plist-get p :toaddress) "?")) - (cons "%s" (plist-get p :subject)) - (cons "%d" (plist-get p :date)) - (cons "%m" (plist-get p :message-id))))) - (when (string-match "%c" fmt) - ;; Check if the user wrote this message - (if (and org-from-is-user-regexp from to - (save-match-data (string-match org-from-is-user-regexp from))) - (setq fmt (replace-match "to %t" t t fmt)) - (setq fmt (replace-match "from %f" t t fmt)))) - (org-replace-escapes fmt table))) - -(defun org-make-org-heading-search-string (&optional string) - "Make search string for the current headline or STRING." - (let ((s (or string - (and (derived-mode-p 'org-mode) - (save-excursion - (org-back-to-heading t) - (org-element-property :raw-value (org-element-at-point)))))) - (lines org-context-in-file-links)) - (unless string (setq s (concat "*" s))) ;Add * for headlines - (setq s (replace-regexp-in-string "\\[[0-9]+%\\]\\|\\[[0-9]+/[0-9]+\\]" "" s)) - (when (and string (integerp lines) (> lines 0)) - (let ((slines (org-split-string s "\n"))) - (when (< lines (length slines)) - (setq s (mapconcat - 'identity - (reverse (nthcdr (- (length slines) lines) - (reverse slines))) "\n"))))) - (mapconcat #'identity (split-string s) " "))) - -(defconst org-link-escape-chars - ;;%20 %5B %5D %25 - '(?\s ?\[ ?\] ?%) - "List of characters that should be escaped in a link when stored to Org. -This is the list that is used for internal purposes.") - -(defun org-make-link-string (link &optional description) - "Make a link with brackets, consisting of LINK and DESCRIPTION." - (unless (org-string-nw-p link) (error "Empty link")) - (let ((uri (cond ((string-match org-link-types-re link) - (concat (match-string 1 link) - (org-link-escape (substring link (match-end 1))))) - ((or (file-name-absolute-p link) - (string-match-p "\\`\\.\\.?/" link)) - (org-link-escape link)) - ;; For readability, do not encode space characters - ;; in fuzzy links. - (t (org-link-escape link (remq ?\s org-link-escape-chars))))) - (description - (and (org-string-nw-p description) - ;; Remove brackets from description, as they are fatal. - (replace-regexp-in-string - "[][]" (lambda (m) (if (equal "[" m) "{" "}")) - (org-trim description))))) - (format "[[%s]%s]" - uri - (if description (format "[%s]" description) "")))) - -(defun org-link-escape (text &optional table merge) - "Return percent escaped representation of TEXT. -TEXT is a string with the text to escape. -Optional argument TABLE is a list with characters that should be -escaped. When nil, `org-link-escape-chars' is used. -If optional argument MERGE is set, merge TABLE into -`org-link-escape-chars'." - (let ((characters-to-encode - (cond ((null table) org-link-escape-chars) - (merge (append org-link-escape-chars table)) - (t table)))) - (mapconcat - (lambda (c) - (if (or (memq c characters-to-encode) - (and org-url-hexify-p (or (< c 32) (> c 126)))) - (mapconcat (lambda (e) (format "%%%.2X" e)) - (or (encode-coding-char c 'utf-8) - (error "Unable to percent escape character: %c" c)) - "") - (char-to-string c))) - text ""))) - -(defun org-link-unescape (str) - "Unhex hexified Unicode parts in string STR. -E.g. `%C3%B6' becomes the german o-Umlaut. This is the -reciprocal of `org-link-escape', which see." - (if (org-string-nw-p str) - (replace-regexp-in-string - "\\(%[0-9A-Za-z]\\{2\\}\\)+" #'org-link-unescape-compound str t t) - str)) - -(defun org-link-unescape-compound (hex) - "Unhexify Unicode hex-chars. E.g. `%C3%B6' is the German o-Umlaut. -Note: this function also decodes single byte encodings like -`%E1' (a-acute) if not followed by another `%[A-F0-9]{2}' group." - (save-match-data - (let* ((bytes (cdr (split-string hex "%"))) - (ret "") - (eat 0) - (sum 0)) - (while bytes - (let* ((val (string-to-number (pop bytes) 16)) - (shift-xor - (if (= 0 eat) - (cond - ((>= val 252) (cons 6 252)) - ((>= val 248) (cons 5 248)) - ((>= val 240) (cons 4 240)) - ((>= val 224) (cons 3 224)) - ((>= val 192) (cons 2 192)) - (t (cons 0 0))) - (cons 6 128)))) - (when (>= val 192) (setq eat (car shift-xor))) - (setq val (logxor val (cdr shift-xor))) - (setq sum (+ (ash sum (car shift-xor)) val)) - (when (> eat 0) (setq eat (- eat 1))) - (cond - ((= 0 eat) ;multi byte - (setq ret (concat ret (char-to-string sum))) - (setq sum 0)) - ((not bytes) ; single byte(s) - (setq ret (org-link-unescape-single-byte-sequence hex)))))) - ret))) - -(defun org-link-unescape-single-byte-sequence (hex) - "Unhexify hex-encoded single byte character sequences." - (mapconcat (lambda (byte) - (char-to-string (string-to-number byte 16))) - (cdr (split-string hex "%")) "")) - -(defun org-fixup-message-id-for-http (s) - "Replace special characters in a message id, so it can be used in an http query." - (when (string-match "%" s) - (setq s (mapconcat (lambda (c) - (if (eq c ?%) - "%25" - (char-to-string c))) - s ""))) - (while (string-match "<" s) - (setq s (replace-match "%3C" t t s))) - (while (string-match ">" s) - (setq s (replace-match "%3E" t t s))) - (while (string-match "@" s) - (setq s (replace-match "%40" t t s))) - s) - -(defun org-link-prettify (link) - "Return a human-readable representation of LINK. -The car of LINK must be a raw link. -The cdr of LINK must be either a link description or nil." - (let ((desc (or (cadr link) "<no description>"))) - (concat (format "%-45s" (substring desc 0 (min (length desc) 40))) - "<" (car link) ">"))) - -;;;###autoload -(defun org-insert-link-global () - "Insert a link like Org mode does. -This command can be called in any mode to insert a link in Org syntax." - (interactive) - (org-load-modules-maybe) - (org-run-like-in-org-mode 'org-insert-link)) - -(defun org-insert-all-links (arg &optional pre post) - "Insert all links in `org-stored-links'. -When a universal prefix, do not delete the links from `org-stored-links'. -When `ARG' is a number, insert the last N link(s). -`PRE' and `POST' are optional arguments to define a string to -prepend or to append." - (interactive "P") - (let ((org-keep-stored-link-after-insertion (equal arg '(4))) - (links (copy-sequence org-stored-links)) - (pr (or pre "- ")) - (po (or post "\n")) - (cnt 1) l) - (if (null org-stored-links) - (message "No link to insert") - (while (and (or (listp arg) (>= arg cnt)) - (setq l (if (listp arg) - (pop links) - (pop org-stored-links)))) - (setq cnt (1+ cnt)) - (insert pr) - (org-insert-link nil (car l) (or (cadr l) "<no description>")) - (insert po))))) - -(defun org-insert-last-stored-link (arg) - "Insert the last link stored in `org-stored-links'." - (interactive "p") - (org-insert-all-links arg "" "\n")) - -(defun org-link-fontify-links-to-this-file () - "Fontify links to the current file in `org-stored-links'." - (let ((f (buffer-file-name)) a b) - (setq a (mapcar (lambda(l) - (let ((ll (car l))) - (when (and (string-match "^file:\\(.+\\)::" ll) - (equal f (expand-file-name (match-string 1 ll)))) - ll))) - org-stored-links)) - (when (featurep 'org-id) - (setq b (mapcar (lambda(l) - (let ((ll (car l))) - (when (and (string-match "^id:\\(.+\\)$" ll) - (equal f (expand-file-name - (or (org-id-find-id-file - (match-string 1 ll)) "")))) - ll))) - org-stored-links))) - (mapcar (lambda(l) - (put-text-property 0 (length l) 'face 'font-lock-comment-face l)) - (delq nil (append a b))))) - -(defvar org--links-history nil) -(defun org-insert-link (&optional complete-file link-location default-description) - "Insert a link. At the prompt, enter the link. - -Completion can be used to insert any of the link protocol prefixes in use. - -The history can be used to select a link previously stored with -`org-store-link'. When the empty string is entered (i.e. if you just -press `RET' at the prompt), the link defaults to the most recently -stored link. As `SPC' triggers completion in the minibuffer, you need to -use `M-SPC' or `C-q SPC' to force the insertion of a space character. - -You will also be prompted for a description, and if one is given, it will -be displayed in the buffer instead of the link. - -If there is already a link at point, this command will allow you to edit -link and description parts. - -With a `\\[universal-argument]' prefix, prompts for a file to link to. The \ -file name can be -selected using completion. The path to the file will be relative to the -current directory if the file is in the current directory or a subdirectory. -Otherwise, the link will be the absolute path as completed in the minibuffer -\(i.e. normally ~/path/to/file). You can configure this behavior using the -option `org-link-file-path-type'. - -With a `\\[universal-argument] \\[universal-argument]' prefix, enforce an \ -absolute path even if the file is in -the current directory or below. - -A `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \ -prefix negates `org-keep-stored-link-after-insertion'. - -If the LINK-LOCATION parameter is non-nil, this value will be used as -the link location instead of reading one interactively. - -If the DEFAULT-DESCRIPTION parameter is non-nil, this value will -be used as the default description. Otherwise, if -`org-make-link-description-function' is non-nil, this function -will be called with the link target, and the result will be the -default link description." - (interactive "P") - (let* ((wcf (current-window-configuration)) - (origbuf (current-buffer)) - (region (when (org-region-active-p) - (buffer-substring (region-beginning) (region-end)))) - (remove (and region (list (region-beginning) (region-end)))) - (desc region) - (link link-location) - (abbrevs org-link-abbrev-alist-local) - entry all-prefixes auto-desc) - (cond - (link-location) ; specified by arg, just use it. - ((org-in-regexp org-bracket-link-regexp 1) - ;; We do have a link at point, and we are going to edit it. - (setq remove (list (match-beginning 0) (match-end 0))) - (setq desc (when (match-end 3) (match-string-no-properties 3))) - (setq link (read-string "Link: " - (org-link-unescape - (match-string-no-properties 1))))) - ((or (org-in-regexp org-angle-link-re) - (org-in-regexp org-plain-link-re)) - ;; Convert to bracket link - (setq remove (list (match-beginning 0) (match-end 0)) - link (read-string "Link: " - (org-unbracket-string "<" ">" (match-string 0))))) - ((member complete-file '((4) (16))) - ;; Completing read for file names. - (setq link (org-file-complete-link complete-file))) - (t - ;; Read link, with completion for stored links. - (org-link-fontify-links-to-this-file) - (org-switch-to-buffer-other-window "*Org Links*") - (with-current-buffer "*Org Links*" - (erase-buffer) - (insert "Insert a link. -Use TAB to complete link prefixes, then RET for type-specific completion support\n") - (when org-stored-links - (insert "\nStored links are available with <up>/<down> or M-p/n (most recent with RET):\n\n") - (insert (mapconcat 'org-link-prettify - (reverse org-stored-links) "\n"))) - (goto-char (point-min))) - (let ((cw (selected-window))) - (select-window (get-buffer-window "*Org Links*" 'visible)) - (with-current-buffer "*Org Links*" (setq truncate-lines t)) - (unless (pos-visible-in-window-p (point-max)) - (org-fit-window-to-buffer)) - (and (window-live-p cw) (select-window cw))) - (setq all-prefixes (append (mapcar 'car abbrevs) - (mapcar 'car org-link-abbrev-alist) - (org-link-types))) - (unwind-protect - ;; Fake a link history, containing the stored links. - (let ((org--links-history - (append (mapcar #'car org-stored-links) - org-insert-link-history))) - (setq link - (org-completing-read - "Link: " - (append - (mapcar (lambda (x) (concat x ":")) all-prefixes) - (mapcar #'car org-stored-links)) - nil nil nil - 'org--links-history - (caar org-stored-links))) - (unless (org-string-nw-p link) (user-error "No link selected")) - (dolist (l org-stored-links) - (when (equal link (cadr l)) - (setq link (car l)) - (setq auto-desc t))) - (when (or (member link all-prefixes) - (and (equal ":" (substring link -1)) - (member (substring link 0 -1) all-prefixes) - (setq link (substring link 0 -1)))) - (setq link (with-current-buffer origbuf - (org-link-try-special-completion link))))) - (set-window-configuration wcf) - (kill-buffer "*Org Links*")) - (setq entry (assoc link org-stored-links)) - (or entry (push link org-insert-link-history)) - (setq desc (or desc (nth 1 entry))))) - - (when (funcall (if (equal complete-file '(64)) 'not 'identity) - (not org-keep-stored-link-after-insertion)) - (setq org-stored-links (delq (assoc link org-stored-links) - org-stored-links))) - - (when (and (string-match org-plain-link-re link) - (not (string-match org-ts-regexp link))) - ;; URL-like link, normalize the use of angular brackets. - (setq link (org-unbracket-string "<" ">" link))) - - ;; Check if we are linking to the current file with a search - ;; option If yes, simplify the link by using only the search - ;; option. - (when (and buffer-file-name - (let ((case-fold-search nil)) - (string-match "\\`file:\\(.+?\\)::" link))) - (let ((path (match-string-no-properties 1 link)) - (search (substring-no-properties link (match-end 0)))) - (save-match-data - (when (equal (file-truename buffer-file-name) (file-truename path)) - ;; We are linking to this same file, with a search option - (setq link search))))) - - ;; Check if we can/should use a relative path. If yes, simplify - ;; the link. - (let ((case-fold-search nil)) - (when (string-match "\\`\\(file\\|docview\\):" link) - (let* ((type (match-string-no-properties 0 link)) - (path-start (match-end 0)) - (search (and (string-match "::\\(.*\\)\\'" link) - (match-string 1 link))) - (path - (if search - (substring-no-properties - link path-start (match-beginning 0)) - (substring-no-properties link (match-end 0)))) - (origpath path)) - (cond - ((or (eq org-link-file-path-type 'absolute) - (equal complete-file '(16))) - (setq path (abbreviate-file-name (expand-file-name path)))) - ((eq org-link-file-path-type 'noabbrev) - (setq path (expand-file-name path))) - ((eq org-link-file-path-type 'relative) - (setq path (file-relative-name path))) - (t - (save-match-data - (if (string-match (concat "^" (regexp-quote - (expand-file-name - (file-name-as-directory - default-directory)))) - (expand-file-name path)) - ;; We are linking a file with relative path name. - (setq path (substring (expand-file-name path) - (match-end 0))) - (setq path (abbreviate-file-name (expand-file-name path))))))) - (setq link (concat type path (and search (concat "::" search)))) - (when (equal desc origpath) - (setq desc path))))) - - (unless auto-desc - (let ((initial-input - (cond - (default-description) - ((not org-make-link-description-function) desc) - (t (condition-case nil - (funcall org-make-link-description-function link desc) - (error - (message "Can't get link description from `%s'" - (symbol-name org-make-link-description-function)) - (sit-for 2) - nil)))))) - (setq desc (read-string "Description: " initial-input)))) - - (unless (string-match "\\S-" desc) (setq desc nil)) - (when remove (apply 'delete-region remove)) - (insert (org-make-link-string link desc)) - ;; Redisplay so as the new link has proper invisible characters. - (sit-for 0))) - -(defun org-link-try-special-completion (type) - "If there is completion support for link type TYPE, offer it." - (let ((fun (org-link-get-parameter type :complete))) - (if (functionp fun) - (funcall fun) - (read-string "Link (no completion support): " (concat type ":"))))) - -(defun org-file-complete-link (&optional arg) - "Create a file link using completion." - (let ((file (read-file-name "File: ")) - (pwd (file-name-as-directory (expand-file-name "."))) - (pwd1 (file-name-as-directory (abbreviate-file-name - (expand-file-name "."))))) - (cond ((equal arg '(16)) - (concat "file:" - (abbreviate-file-name (expand-file-name file)))) - ((string-match - (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) - (concat "file:" (match-string 1 file))) - ((string-match - (concat "^" (regexp-quote pwd) "\\(.+\\)") - (expand-file-name file)) - (concat "file:" - (match-string 1 (expand-file-name file)))) - (t (concat "file:" file))))) - -(defun org-completing-read (&rest args) - "Completing-read with SPACE being a normal character." - (let ((enable-recursive-minibuffers t) - (minibuffer-local-completion-map - (copy-keymap minibuffer-local-completion-map))) - (org-defkey minibuffer-local-completion-map " " 'self-insert-command) - (org-defkey minibuffer-local-completion-map "?" 'self-insert-command) - (org-defkey minibuffer-local-completion-map (kbd "C-c !") - 'org-time-stamp-inactive) - (apply #'completing-read args))) - -;;; Opening/following a link - -(defvar org-link-search-failed nil) - -(defvar org-open-link-functions nil - "Hook for functions finding a plain text link. -These functions must take a single argument, the link content. -They will be called for links that look like [[link text][description]] -when LINK TEXT does not have a protocol like \"http:\" and does not look -like a filename (e.g. \"./blue.png\"). - -These functions will be called *before* Org attempts to resolve the -link by doing text searches in the current buffer - so if you want a -link \"[[target]]\" to still find \"<<target>>\", your function should -handle this as a special case. - -When the function does handle the link, it must return a non-nil value. -If it decides that it is not responsible for this link, it must return -nil to indicate that that Org can continue with other options like -exact and fuzzy text search.") - -(defun org-next-link (&optional search-backward) - "Move forward to the next link. -If the link is in hidden text, expose it." - (interactive "P") - (when (and org-link-search-failed (eq this-command last-command)) - (goto-char (point-min)) - (message "Link search wrapped back to beginning of buffer")) - (setq org-link-search-failed nil) - (let* ((pos (point)) - (ct (org-context)) - (a (assq :link ct)) - (srch-fun (if search-backward 're-search-backward 're-search-forward))) - (cond (a (goto-char (nth (if search-backward 1 2) a))) - ((looking-at org-any-link-re) - ;; Don't stay stuck at link without an org-link face - (forward-char (if search-backward -1 1)))) - (if (funcall srch-fun org-any-link-re nil t) - (progn - (goto-char (match-beginning 0)) - (when (org-invisible-p) (org-show-context))) - (goto-char pos) - (setq org-link-search-failed t) - (message "No further link found")))) - -(defun org-previous-link () - "Move backward to the previous link. -If the link is in hidden text, expose it." - (interactive) - (funcall 'org-next-link t)) - -(defun org-translate-link (s) - "Translate a link string if a translation function has been defined." - (with-temp-buffer - (insert (org-trim s)) - (org-trim (org-element-interpret-data (org-element-context))))) - -(defun org-translate-link-from-planner (type path) - "Translate a link from Emacs Planner syntax so that Org can follow it. -This is still an experimental function, your mileage may vary." - (cond - ((member type '("http" "https" "news" "ftp")) - ;; standard Internet links are the same. - nil) - ((and (equal type "irc") (string-match "^//" path)) - ;; Planner has two / at the beginning of an irc link, we have 1. - ;; We should have zero, actually.... - (setq path (substring path 1))) - ((and (equal type "lisp") (string-match "^/" path)) - ;; Planner has a slash, we do not. - (setq type "elisp" path (substring path 1))) - ((string-match "^//\\(.*\\)/\\(<.*>\\)$" path) - ;; A typical message link. Planner has the id after the final slash, - ;; we separate it with a hash mark - (setq path (concat (match-string 1 path) "#" - (org-unbracket-string "<" ">" (match-string 2 path)))))) - (cons type path)) - (defun org-find-file-at-mouse (ev) "Open file link or URL at mouse." (interactive "e") @@ -10488,36 +8381,226 @@ See the docstring of `org-open-file' for details." "The window configuration before following a link. This is saved in case the need arises to restore it.") +(defun org--file-default-apps () + "Return the default applications for this operating system." + (pcase system-type + (`darwin org-file-apps-macos) + (`windows-nt org-file-apps-windowsnt) + (_ org-file-apps-gnu))) + +(defun org--file-apps-entry-dlink-p (entry) + "Non-nil if ENTRY should be matched against the link by `org-open-file'. + +It assumes that is the case when the entry uses a regular +expression which has at least one grouping construct and the +action is either a Lisp form or a command string containing +\"%1\", i.e., using at least one subexpression match as +a parameter." + (pcase entry + (`(,selector . ,action) + (and (stringp selector) + (> (regexp-opt-depth selector) 0) + (or (and (stringp action) + (string-match "%[0-9]" action)) + (consp action)))) + (_ nil))) + +(defun org--file-apps-regexp-alist (list &optional add-auto-mode) + "Convert extensions to regular expressions in the cars of LIST. + +Also, weed out any non-string entries, because the return value +is used only for regexp matching. + +When ADD-AUTO-MODE is non-nil, make all matches in `auto-mode-alist' +point to the symbol `emacs', indicating that the file should be +opened in Emacs." + (append + (delq nil + (mapcar (lambda (x) + (unless (not (stringp (car x))) + (if (string-match "\\W" (car x)) + x + (cons (concat "\\." (car x) "\\'") (cdr x))))) + list)) + (when add-auto-mode + (mapcar (lambda (x) (cons (car x) 'emacs)) auto-mode-alist)))) + ;;;###autoload -(defun org-open-at-point-global () - "Follow a link or time-stamp like Org mode does. -This command can be called in any mode to follow an external link -or a time-stamp that has Org mode syntax. Its behavior is -undefined when called on internal links (e.g., fuzzy links). -Raise an error when there is nothing to follow." - (interactive) - (cond ((org-in-regexp org-any-link-re) - (org-open-link-from-string (match-string-no-properties 0))) - ((or (org-in-regexp org-ts-regexp-both nil t) - (org-in-regexp org-tsr-regexp-both nil t)) - (org-follow-timestamp-link)) - (t (user-error "No link found")))) +(defun org-open-file (path &optional in-emacs line search) + "Open the file at PATH. +First, this expands any special file name abbreviations. Then the +configuration variable `org-file-apps' is checked if it contains an +entry for this file type, and if yes, the corresponding command is launched. + +If no application is found, Emacs simply visits the file. + +With optional prefix argument IN-EMACS, Emacs will visit the file. +With a double \\[universal-argument] \\[universal-argument] \ +prefix arg, Org tries to avoid opening in Emacs +and to use an external application to visit the file. + +Optional LINE specifies a line to go to, optional SEARCH a string +to search for. If LINE or SEARCH is given, the file will be +opened in Emacs, unless an entry from `org-file-apps' that makes +use of groups in a regexp matches. + +If you want to change the way frames are used when following a +link, please customize `org-link-frame-setup'. + +If the file does not exist, throw an error." + (let* ((file (if (equal path "") buffer-file-name + (substitute-in-file-name (expand-file-name path)))) + (file-apps (append org-file-apps (org--file-default-apps))) + (apps (cl-remove-if #'org--file-apps-entry-dlink-p file-apps)) + (apps-dlink (cl-remove-if-not #'org--file-apps-entry-dlink-p + file-apps)) + (remp (and (assq 'remote apps) (file-remote-p file))) + (dirp (unless remp (file-directory-p file))) + (file (if (and dirp org-open-directory-means-index-dot-org) + (concat (file-name-as-directory file) "index.org") + file)) + (a-m-a-p (assq 'auto-mode apps)) + (dfile (downcase file)) + ;; Reconstruct the original link from the PATH, LINE and + ;; SEARCH args. + (link (cond (line (concat file "::" (number-to-string line))) + (search (concat file "::" search)) + (t file))) + (dlink (downcase link)) + (ext + (and (string-match "\\`.*?\\.\\([a-zA-Z0-9]+\\(\\.gz\\)?\\)\\'" dfile) + (match-string 1 dfile))) + (save-position-maybe + (let ((old-buffer (current-buffer)) + (old-pos (point)) + (old-mode major-mode)) + (lambda () + (and (derived-mode-p 'org-mode) + (eq old-mode 'org-mode) + (or (not (eq old-buffer (current-buffer))) + (not (eq old-pos (point)))) + (org-mark-ring-push old-pos old-buffer))))) + cmd link-match-data) + (cond + ((member in-emacs '((16) system)) + (setq cmd (cdr (assq 'system apps)))) + (in-emacs (setq cmd 'emacs)) + (t + (setq cmd (or (and remp (cdr (assq 'remote apps))) + (and dirp (cdr (assq 'directory apps))) + ;; First, try matching against apps-dlink if we + ;; get a match here, store the match data for + ;; later. + (let ((match (assoc-default dlink apps-dlink + 'string-match))) + (if match + (progn (setq link-match-data (match-data)) + match) + (progn (setq in-emacs (or in-emacs line search)) + nil))) ; if we have no match in apps-dlink, + ; always open the file in emacs if line or search + ; is given (for backwards compatibility) + (assoc-default dfile + (org--file-apps-regexp-alist apps a-m-a-p) + 'string-match) + (cdr (assoc ext apps)) + (cdr (assq t apps)))))) + (when (eq cmd 'system) + (setq cmd (cdr (assq 'system apps)))) + (when (eq cmd 'default) + (setq cmd (cdr (assoc t apps)))) + (when (eq cmd 'mailcap) + (require 'mailcap) + (mailcap-parse-mailcaps) + (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) + (command (mailcap-mime-info mime-type))) + (if (stringp command) + (setq cmd command) + (setq cmd 'emacs)))) + (when (and (not (eq cmd 'emacs)) ; Emacs has no problems with non-ex files + (not (file-exists-p file)) + (not org-open-non-existing-files)) + (user-error "No such file: %s" file)) + (cond + ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) + ;; Remove quotes around the file name - we'll use shell-quote-argument. + (while (string-match "['\"]%s['\"]" cmd) + (setq cmd (replace-match "%s" t t cmd))) + (setq cmd (replace-regexp-in-string + "%s" + (shell-quote-argument (convert-standard-filename file)) + cmd + nil t)) + + ;; Replace "%1", "%2" etc. in command with group matches from regex + (save-match-data + (let ((match-index 1) + (number-of-groups (- (/ (length link-match-data) 2) 1))) + (set-match-data link-match-data) + (while (<= match-index number-of-groups) + (let ((regex (concat "%" (number-to-string match-index))) + (replace-with (match-string match-index dlink))) + (while (string-match regex cmd) + (setq cmd (replace-match replace-with t t cmd)))) + (setq match-index (+ match-index 1))))) + + (save-window-excursion + (message "Running %s...done" cmd) + (start-process-shell-command cmd nil cmd) + (and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait)))) + ((or (stringp cmd) + (eq cmd 'emacs)) + (funcall (cdr (assq 'file org-link-frame-setup)) file) + (widen) + (cond (line (org-goto-line line) + (when (derived-mode-p 'org-mode) (org-reveal))) + (search (condition-case err + (org-link-search search) + ;; Save position before error-ing out so user + ;; can easily move back to the original buffer. + (error (funcall save-position-maybe) + (error (nth 1 err))))))) + ((functionp cmd) + (save-match-data + (set-match-data link-match-data) + (condition-case nil + (funcall cmd file link) + ;; FIXME: Remove this check when most default installations + ;; of Emacs have at least Org 9.0. + ((debug wrong-number-of-arguments wrong-type-argument + invalid-function) + (user-error "Please see Org News for version 9.0 about \ +`org-file-apps'--Lisp error: %S" cmd))))) + ((consp cmd) + ;; FIXME: Remove this check when most default installations of + ;; Emacs have at least Org 9.0. Heads-up instead of silently + ;; fall back to `org-link-frame-setup' for an old usage of + ;; `org-file-apps' with sexp instead of a function for `cmd'. + (user-error "Please see Org News for version 9.0 about \ +`org-file-apps'--Error: Deprecated usage of %S" cmd)) + (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) + (funcall save-position-maybe))) ;;;###autoload -(defun org-open-link-from-string (s &optional arg reference-buffer) - "Open a link in the string S, as if it was in Org mode." - (interactive "sLink: \nP") - (let ((reference-buffer (or reference-buffer (current-buffer)))) - (with-temp-buffer - (let ((org-inhibit-startup (not reference-buffer))) - (org-mode) - (insert s) - (goto-char (point-min)) - (when reference-buffer - (setq org-link-abbrev-alist-local - (with-current-buffer reference-buffer - org-link-abbrev-alist-local))) - (org-open-at-point arg reference-buffer))))) +(defun org-open-at-point-global () + "Follow a link or a time-stamp like Org mode does. +Also follow links and emails as seen by `thing-at-point'. +This command can be called in any mode to follow an external +link or a time-stamp that has Org mode syntax. Its behavior +is undefined when called on internal links like fuzzy links. +Raise a user error when there is nothing to follow." + (interactive) + (let ((tap-url (thing-at-point 'url)) + (tap-email (thing-at-point 'email))) + (cond ((org-in-regexp org-link-any-re) + (org-link-open-from-string (match-string-no-properties 0))) + ((or (org-in-regexp org-ts-regexp-both nil t) + (org-in-regexp org-tsr-regexp-both nil t)) + (org-follow-timestamp-link)) + (tap-url (org-link-open-from-string tap-url)) + (tap-email (org-link-open-from-string + (concat "mailto:" tap-email))) + (t (user-error "No link found"))))) (defvar org-open-at-point-functions nil "Hook that is run when following a link at point. @@ -10526,62 +8609,7 @@ Functions in this hook must return t if they identify and follow a link at point. If they don't find anything interesting at point, they must return nil.") -(defvar org-link-search-inhibit-query nil) -(defvar clean-buffer-list-kill-buffer-names) ;Defined in midnight.el -(defun org--open-doi-link (path) - "Open a \"doi\" type link. -PATH is a the path to search for, as a string." - (browse-url (url-encode-url (concat org-doi-server-url path)))) - -(defun org--open-elisp-link (path) - "Open a \"elisp\" type link. -PATH is the sexp to evaluate, as a string." - (let ((cmd path)) - (if (or (and (org-string-nw-p - org-confirm-elisp-link-not-regexp) - (string-match-p org-confirm-elisp-link-not-regexp cmd)) - (not org-confirm-elisp-link-function) - (funcall org-confirm-elisp-link-function - (format "Execute \"%s\" as elisp? " - (org-add-props cmd nil 'face 'org-warning)))) - (message "%s => %s" cmd - (if (eq (string-to-char cmd) ?\() - (eval (read cmd)) - (call-interactively (read cmd)))) - (user-error "Abort")))) - -(defun org--open-help-link (path) - "Open a \"help\" type link. -PATH is a symbol name, as a string." - (pcase (intern path) - ((and (pred fboundp) variable) (describe-function variable)) - ((and (pred boundp) function) (describe-variable function)) - (name (user-error "Unknown function or variable: %s" name)))) - -(defun org--open-shell-link (path) - "Open a \"shell\" type link. -PATH is the command to execute, as a string." - (let ((buf (generate-new-buffer "*Org Shell Output*")) - (cmd path)) - (if (or (and (org-string-nw-p - org-confirm-shell-link-not-regexp) - (string-match - org-confirm-shell-link-not-regexp cmd)) - (not org-confirm-shell-link-function) - (funcall org-confirm-shell-link-function - (format "Execute \"%s\" in shell? " - (org-add-props cmd nil - 'face 'org-warning)))) - (progn - (message "Executing %s" cmd) - (shell-command cmd buf) - (when (featurep 'midnight) - (setq clean-buffer-list-kill-buffer-names - (cons (buffer-name buf) - clean-buffer-list-kill-buffer-names)))) - (user-error "Abort")))) - -(defun org-open-at-point (&optional arg reference-buffer) +(defun org-open-at-point (&optional arg) "Open link, timestamp, footnote or tags at point. When point is on a link, follow it. Normally, files will be @@ -10601,153 +8629,101 @@ When point is on a headline, display a list of every link in the entry, so it is possible to pick one, or all, of them. If point is on a tag, call `org-tags-view' instead. -When optional argument REFERENCE-BUFFER is non-nil, it should -specify a buffer from where the link search should happen. This -is used internally by `org-open-link-from-string'. - -On top of syntactically correct links, this function will also -try to open links and time-stamps in comments, example -blocks... i.e., whenever point is on something looking like -a timestamp or a link." +On top of syntactically correct links, this function also tries +to open links and time-stamps in comments, node properties, and +keywords if point is on something looking like a timestamp or +a link." (interactive "P") - ;; On a code block, open block's results. - (unless (call-interactively 'org-babel-open-src-block-result) - (org-load-modules-maybe) - (setq org-window-config-before-follow-link (current-window-configuration)) - (org-remove-occur-highlights nil nil t) - (unless (run-hook-with-args-until-success 'org-open-at-point-functions) - (let* ((context - ;; Only consider supported types, even if they are not - ;; the closest one. - (org-element-lineage - (org-element-context) - '(clock footnote-definition footnote-reference headline - inlinetask link timestamp) - t)) - (type (org-element-type context)) - (value (org-element-property :value context))) - (cond - ;; On a headline or an inlinetask, but not on a timestamp, - ;; a link, a footnote reference. - ((memq type '(headline inlinetask)) - (org-match-line org-complex-heading-regexp) - (if (and (match-beginning 5) - (>= (point) (match-beginning 5)) - (< (point) (match-end 5))) - ;; On tags. - (org-tags-view arg (substring (match-string 5) 0 -1)) - ;; Not on tags. - (pcase (org-offer-links-in-entry (current-buffer) (point) arg) - (`(nil . ,_) - (require 'org-attach) - (org-attach-reveal 'if-exists)) - (`(,links . ,links-end) - (dolist (link (if (stringp links) (list links) links)) - (search-forward link nil links-end) - (goto-char (match-beginning 0)) - (org-open-at-point)))))) - ;; On a footnote reference or at definition's label. - ((or (eq type 'footnote-reference) - (and (eq type 'footnote-definition) - (save-excursion - ;; Do not validate action when point is on the - ;; spaces right after the footnote label, in - ;; order to be on par with behavior on links. - (skip-chars-forward " \t") - (let ((begin - (org-element-property :contents-begin context))) - (if begin (< (point) begin) - (= (org-element-property :post-affiliated context) - (line-beginning-position))))))) - (org-footnote-action)) - ;; No valid context. Ignore catch-all types like `headline'. - ;; If point is on something looking like a link or - ;; a time-stamp, try opening it. It may be useful in - ;; comments, example blocks... - ((memq type '(footnote-definition headline inlinetask nil)) - (call-interactively #'org-open-at-point-global)) - ;; On a clock line, make sure point is on the timestamp - ;; before opening it. - ((and (eq type 'clock) - value - (>= (point) (org-element-property :begin value)) - (<= (point) (org-element-property :end value))) - (org-follow-timestamp-link)) - ;; Do nothing on white spaces after an object. - ((>= (point) - (save-excursion - (goto-char (org-element-property :end context)) - (skip-chars-backward " \t") - (point))) - (user-error "No link found")) - ((eq type 'timestamp) (org-follow-timestamp-link)) - ((eq type 'link) - (let ((type (org-element-property :type context)) - (path (org-link-unescape (org-element-property :path context)))) - ;; Switch back to REFERENCE-BUFFER needed when called in - ;; a temporary buffer through `org-open-link-from-string'. - (with-current-buffer (or reference-buffer (current-buffer)) - (cond - ((equal type "file") - (if (string-match "[*?{]" (file-name-nondirectory path)) - (dired path) - ;; Look into `org-link-parameters' in order to find - ;; a DEDICATED-FUNCTION to open file. The function - ;; will be applied on raw link instead of parsed - ;; link due to the limitation in `org-add-link-type' - ;; ("open" function called with a single argument). - ;; If no such function is found, fallback to - ;; `org-open-file'. - (let* ((option (org-element-property :search-option context)) - (app (org-element-property :application context)) - (dedicated-function - (org-link-get-parameter - (if app (concat type "+" app) type) - :follow))) - (if dedicated-function - (funcall dedicated-function - (concat path - (and option (concat "::" option)))) - (apply #'org-open-file - path - (cond (arg) - ((equal app "emacs") 'emacs) - ((equal app "sys") 'system)) - (cond ((not option) nil) - ((string-match-p "\\`[0-9]+\\'" option) - (list (string-to-number option))) - (t (list nil - (org-link-unescape option))))))))) - ((functionp (org-link-get-parameter type :follow)) - (funcall (org-link-get-parameter type :follow) path)) - ((member type '("coderef" "custom-id" "fuzzy" "radio")) - (unless (run-hook-with-args-until-success - 'org-open-link-functions path) - (if (not arg) (org-mark-ring-push) - (switch-to-buffer-other-window - (org-get-buffer-for-internal-link (current-buffer)))) - (let ((destination - (org-with-wide-buffer - (if (equal type "radio") - (org-search-radio-target - (org-element-property :path context)) - (org-link-search - (if (member type '("custom-id" "coderef")) - (org-element-property :raw-link context) - path) - ;; Prevent fuzzy links from matching - ;; themselves. - (and (equal type "fuzzy") - (+ 2 (org-element-property :begin context))))) - (point)))) - (unless (and (<= (point-min) destination) - (>= (point-max) destination)) - (widen)) - (goto-char destination)))) - (t (browse-url-at-point)))))) - (t (user-error "No link found"))))) - (run-hook-with-args 'org-follow-link-hook))) + (org-load-modules-maybe) + (setq org-window-config-before-follow-link (current-window-configuration)) + (org-remove-occur-highlights nil nil t) + (unless (run-hook-with-args-until-success 'org-open-at-point-functions) + (let* ((context + ;; Only consider supported types, even if they are not the + ;; closest one. + (org-element-lineage + (org-element-context) + '(clock comment comment-block footnote-definition + footnote-reference headline inline-src-block inlinetask + keyword link node-property planning src-block timestamp) + t)) + (type (org-element-type context)) + (value (org-element-property :value context))) + (cond + ((not type) (user-error "No link found")) + ;; No valid link at point. For convenience, look if something + ;; looks like a link under point in some specific places. + ((memq type '(comment comment-block node-property keyword)) + (call-interactively #'org-open-at-point-global)) + ;; On a headline or an inlinetask, but not on a timestamp, + ;; a link, a footnote reference. + ((memq type '(headline inlinetask)) + (org-match-line org-complex-heading-regexp) + (if (and (match-beginning 5) + (>= (point) (match-beginning 5)) + (< (point) (match-end 5))) + ;; On tags. + (org-tags-view + arg + (save-excursion + (let* ((beg (match-beginning 5)) + (end (match-end 5)) + (beg-tag (or (search-backward ":" beg 'at-limit) (point))) + (end-tag (search-forward ":" end nil 2))) + (buffer-substring (1+ beg-tag) (1- end-tag))))) + ;; Not on tags. + (pcase (org-offer-links-in-entry (current-buffer) (point) arg) + (`(nil . ,_) + (require 'org-attach) + (message "Opening attachment-dir") + (if (equal arg '(4)) + (org-attach-reveal-in-emacs) + (org-attach-reveal))) + (`(,links . ,links-end) + (dolist (link (if (stringp links) (list links) links)) + (search-forward link nil links-end) + (goto-char (match-beginning 0)) + (org-open-at-point arg)))))) + ;; On a footnote reference or at definition's label. + ((or (eq type 'footnote-reference) + (and (eq type 'footnote-definition) + (save-excursion + ;; Do not validate action when point is on the + ;; spaces right after the footnote label, in order + ;; to be on par with behavior on links. + (skip-chars-forward " \t") + (let ((begin + (org-element-property :contents-begin context))) + (if begin (< (point) begin) + (= (org-element-property :post-affiliated context) + (line-beginning-position))))))) + (org-footnote-action)) + ;; On a planning line. Check if we are really on a timestamp. + ((and (eq type 'planning) + (org-in-regexp org-ts-regexp-both nil t)) + (org-follow-timestamp-link)) + ;; On a clock line, make sure point is on the timestamp + ;; before opening it. + ((and (eq type 'clock) + value + (>= (point) (org-element-property :begin value)) + (<= (point) (org-element-property :end value))) + (org-follow-timestamp-link)) + ((eq type 'src-block) (org-babel-open-src-block-result)) + ;; Do nothing on white spaces after an object. + ((>= (point) + (save-excursion + (goto-char (org-element-property :end context)) + (skip-chars-backward " \t") + (point))) + (user-error "No link found")) + ((eq type 'inline-src-block) (org-babel-open-src-block-result)) + ((eq type 'timestamp) (org-follow-timestamp-link)) + ((eq type 'link) (org-link-open context arg)) + (t (user-error "No link found"))))) + (run-hook-with-args 'org-follow-link-hook)) +;;;###autoload (defun org-offer-links-in-entry (buffer marker &optional nth zero) "Offer links in the current entry and return the selected link. If there is only one link, return it. @@ -10759,13 +8735,13 @@ there is one, return it." (goto-char marker) (let ((cnt ?0) have-zero end links link c) - (when (and (stringp zero) (string-match org-bracket-link-regexp zero)) + (when (and (stringp zero) (string-match org-link-bracket-re zero)) (push (match-string 0 zero) links) (setq cnt (1- cnt) have-zero t)) (save-excursion (org-back-to-heading t) (setq end (save-excursion (outline-next-heading) (point))) - (while (re-search-forward org-any-link-re end t) + (while (re-search-forward org-link-any-re end t) (push (match-string 0) links)) (setq links (org-uniquify (reverse links)))) (cond @@ -10782,12 +8758,12 @@ there is one, return it." (with-output-to-temp-buffer "*Select Link*" (dolist (l links) (cond - ((not (string-match org-bracket-link-regexp l)) + ((not (string-match org-link-bracket-re l)) (princ (format "[%c] %s\n" (cl-incf cnt) (org-unbracket-string "<" ">" l)))) - ((match-end 3) + ((match-end 2) (princ (format "[%c] %s (%s)\n" (cl-incf cnt) - (match-string 3 l) (match-string 1 l)))) + (match-string 2 l) (match-string 1 l)))) (t (princ (format "[%c] %s\n" (cl-incf cnt) (match-string 1 l))))))) (org-fit-window-to-buffer (get-buffer-window "*Select Link*")) @@ -10804,268 +8780,8 @@ there is one, return it." (setq link (nth (1- nth) links))))) (cons link end))))) -;; TODO: These functions are deprecated since `org-open-at-point' -;; hard-codes behavior for "file+emacs" and "file+sys" types. -(defun org-open-file-with-system (path) - "Open file at PATH using the system way of opening it." - (org-open-file path 'system)) -(defun org-open-file-with-emacs (path) - "Open file at PATH in Emacs." - (org-open-file path 'emacs)) - - ;;; File search -(defvar org-create-file-search-functions nil - "List of functions to construct the right search string for a file link. -These functions are called in turn with point at the location to -which the link should point. - -A function in the hook should first test if it would like to -handle this file type, for example by checking the `major-mode' -or the file extension. If it decides not to handle this file, it -should just return nil to give other functions a chance. If it -does handle the file, it must return the search string to be used -when following the link. The search string will be part of the -file link, given after a double colon, and `org-open-at-point' -will automatically search for it. If special measures must be -taken to make the search successful, another function should be -added to the companion hook `org-execute-file-search-functions', -which see. - -A function in this hook may also use `setq' to set the variable -`description' to provide a suggestion for the descriptive text to -be used for this link when it gets inserted into an Org buffer -with \\[org-insert-link].") - -(defvar org-execute-file-search-functions nil - "List of functions to execute a file search triggered by a link. - -Functions added to this hook must accept a single argument, the -search string that was part of the file link, the part after the -double colon. The function must first check if it would like to -handle this search, for example by checking the `major-mode' or -the file extension. If it decides not to handle this search, it -should just return nil to give other functions a chance. If it -does handle the search, it must return a non-nil value to keep -other functions from trying. - -Each function can access the current prefix argument through the -variable `current-prefix-arg'. Note that a single prefix is used -to force opening a link in Emacs, so it may be good to only use a -numeric or double prefix to guide the search function. - -In case this is needed, a function in this hook can also restore -the window configuration before `org-open-at-point' was called using: - - (set-window-configuration org-window-config-before-follow-link)") - -(defun org-search-radio-target (target) - "Search a radio target matching TARGET in current buffer. -White spaces are not significant." - (let ((re (format "<<<%s>>>" - (mapconcat #'regexp-quote - (split-string target) - "[ \t]+\\(?:\n[ \t]*\\)?"))) - (origin (point))) - (goto-char (point-min)) - (catch :radio-match - (while (re-search-forward re nil t) - (backward-char) - (let ((object (org-element-context))) - (when (eq (org-element-type object) 'radio-target) - (goto-char (org-element-property :begin object)) - (org-show-context 'link-search) - (throw :radio-match nil)))) - (goto-char origin) - (user-error "No match for radio target: %s" target)))) - -(defun org-link-search (s &optional avoid-pos stealth) - "Search for a search string S. - -If S starts with \"#\", it triggers a custom ID search. - -If S is enclosed within parenthesis, it initiates a coderef -search. - -If S is surrounded by forward slashes, it is interpreted as -a regular expression. In Org mode files, this will create an -`org-occur' sparse tree. In ordinary files, `occur' will be used -to list matches. If the current buffer is in `dired-mode', grep -will be used to search in all files. - -When AVOID-POS is given, ignore matches near that position. - -When optional argument STEALTH is non-nil, do not modify -visibility around point, thus ignoring `org-show-context-detail' -variable. - -Search is case-insensitive and ignores white spaces. Return type -of matched result, which is either `dedicated' or `fuzzy'." - (unless (org-string-nw-p s) (error "Invalid search string \"%s\"" s)) - (let* ((case-fold-search t) - (origin (point)) - (normalized (replace-regexp-in-string "\n[ \t]*" " " s)) - (starred (eq (string-to-char normalized) ?*)) - (words (split-string (if starred (substring s 1) s))) - (s-multi-re (mapconcat #'regexp-quote words "\\(?:[ \t\n]+\\)")) - (s-single-re (mapconcat #'regexp-quote words "[ \t]+")) - type) - (cond - ;; Check if there are any special search functions. - ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) - ((eq (string-to-char s) ?#) - ;; Look for a custom ID S if S starts with "#". - (let* ((id (substring normalized 1)) - (match (org-find-property "CUSTOM_ID" id))) - (if match (progn (goto-char match) (setf type 'dedicated)) - (error "No match for custom ID: %s" id)))) - ((string-match "\\`(\\(.*\\))\\'" normalized) - ;; Look for coderef targets if S is enclosed within parenthesis. - (let ((coderef (match-string-no-properties 1 normalized)) - (re (substring s-single-re 1 -1))) - (goto-char (point-min)) - (catch :coderef-match - (while (re-search-forward re nil t) - (let ((element (org-element-at-point))) - (when (and (memq (org-element-type element) - '(example-block src-block)) - ;; Build proper regexp according to current - ;; block's label format. - (let ((label-fmt - (regexp-quote - (or (org-element-property :label-fmt element) - org-coderef-label-format)))) - (save-excursion - (beginning-of-line) - (looking-at (format ".*?\\(%s\\)[ \t]*$" - (format label-fmt coderef)))))) - (setq type 'dedicated) - (goto-char (match-beginning 1)) - (throw :coderef-match nil)))) - (goto-char origin) - (error "No match for coderef: %s" coderef)))) - ((string-match "\\`/\\(.*\\)/\\'" normalized) - ;; Look for a regular expression. - (funcall (if (derived-mode-p 'org-mode) #'org-occur #'org-do-occur) - (match-string 1 s))) - ;; From here, we handle fuzzy links. - ;; - ;; Look for targets, only if not in a headline search. - ((and (not starred) - (let ((target (format "<<%s>>" s-multi-re))) - (catch :target-match - (goto-char (point-min)) - (while (re-search-forward target nil t) - (backward-char) - (let ((context (org-element-context))) - (when (eq (org-element-type context) 'target) - (setq type 'dedicated) - (goto-char (org-element-property :begin context)) - (throw :target-match t)))) - nil)))) - ;; Look for elements named after S, only if not in a headline - ;; search. - ((and (not starred) - (let ((name (format "^[ \t]*#\\+NAME: +%s[ \t]*$" s-single-re))) - (catch :name-match - (goto-char (point-min)) - (while (re-search-forward name nil t) - (let ((element (org-element-at-point))) - (when (equal words - (split-string - (org-element-property :name element))) - (setq type 'dedicated) - (beginning-of-line) - (throw :name-match t)))) - nil)))) - ;; Regular text search. Prefer headlines in Org mode buffers. - ;; Ignore COMMENT keyword, TODO keywords, priority cookies, - ;; statistics cookies and tags. - ((and (derived-mode-p 'org-mode) - (let ((title-re - (format "%s.*\\(?:%s[ \t]\\)?.*%s" - org-outline-regexp-bol - org-comment-string - (mapconcat #'regexp-quote words ".+"))) - (cookie-re "\\[[0-9]*\\(?:%\\|/[0-9]*\\)\\]") - (comment-re (eval-when-compile - (format "\\`%s[ \t]+" org-comment-string)))) - (goto-char (point-min)) - (catch :found - (while (re-search-forward title-re nil t) - (when (equal words - (split-string - (replace-regexp-in-string - cookie-re "" - (replace-regexp-in-string - comment-re "" (org-get-heading t t t))))) - (throw :found t))) - nil))) - (beginning-of-line) - (setq type 'dedicated)) - ;; Offer to create non-existent headline depending on - ;; `org-link-search-must-match-exact-headline'. - ((and (derived-mode-p 'org-mode) - (not org-link-search-inhibit-query) - (eq org-link-search-must-match-exact-headline 'query-to-create) - (yes-or-no-p "No match - create this as a new heading? ")) - (goto-char (point-max)) - (unless (bolp) (newline)) - (org-insert-heading nil t t) - (insert s "\n") - (beginning-of-line 0)) - ;; Only headlines are looked after. No need to process - ;; further: throw an error. - ((and (derived-mode-p 'org-mode) - (or starred org-link-search-must-match-exact-headline)) - (goto-char origin) - (error "No match for fuzzy expression: %s" normalized)) - ;; Regular text search. - ((catch :fuzzy-match - (goto-char (point-min)) - (while (re-search-forward s-multi-re nil t) - ;; Skip match if it contains AVOID-POS or it is included in - ;; a link with a description but outside the description. - (unless (or (and avoid-pos - (<= (match-beginning 0) avoid-pos) - (> (match-end 0) avoid-pos)) - (and (save-match-data - (org-in-regexp org-bracket-link-regexp)) - (match-beginning 3) - (or (> (match-beginning 3) (point)) - (<= (match-end 3) (point))) - (org-element-lineage - (save-match-data (org-element-context)) - '(link) t))) - (goto-char (match-beginning 0)) - (setq type 'fuzzy) - (throw :fuzzy-match t))) - nil)) - ;; All failed. Throw an error. - (t (goto-char origin) - (error "No match for fuzzy expression: %s" normalized))) - ;; Disclose surroundings of match, if appropriate. - (when (and (derived-mode-p 'org-mode) (not stealth)) - (org-show-context 'link-search)) - type)) - -(defun org-get-buffer-for-internal-link (buffer) - "Return a buffer to be used for displaying the link target of internal links." - (cond - ((not org-display-internal-link-with-indirect-buffer) - buffer) - ((string-suffix-p "(Clone)" (buffer-name buffer)) - (message "Buffer is already a clone, not making another one") - ;; we also do not modify visibility in this case - buffer) - (t ; make a new indirect buffer for displaying the link - (let* ((bn (buffer-name buffer)) - (ibn (concat bn "(Clone)")) - (ib (or (get-buffer ibn) (make-indirect-buffer buffer ibn 'clone)))) - (with-current-buffer ib (org-overview)) - ib)))) - (defun org-do-occur (regexp &optional cleanup) "Call the Emacs command `occur'. If CLEANUP is non-nil, remove the printout of the regular expression @@ -11085,31 +8801,37 @@ to read." (goto-char (point-min)) (select-window cwin)))) -;;; The mark ring for links jumps + +;;; The Mark Ring (defvar org-mark-ring nil "Mark ring for positions before jumps in Org mode.") + (defvar org-mark-ring-last-goto nil "Last position in the mark ring used to go back.") + ;; Fill and close the ring -(setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded -(dotimes (_ org-mark-ring-length) - (push (make-marker) org-mark-ring)) +(setq org-mark-ring nil) +(setq org-mark-ring-last-goto nil) ;in case file is reloaded + +(dotimes (_ org-mark-ring-length) (push (make-marker) org-mark-ring)) (setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) org-mark-ring) (defun org-mark-ring-push (&optional pos buffer) - "Put the current position or POS into the mark ring and rotate it." + "Put the current position into the mark ring and rotate it. +Also push position into the Emacs mark ring. If optional +argument POS and BUFFER are not nil, mark this location instead." (interactive) - (setq pos (or pos (point))) - (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) - (move-marker (car org-mark-ring) - (or pos (point)) - (or buffer (current-buffer))) - (message "%s" - (substitute-command-keys - "Position saved to mark ring, go back with \ -`\\[org-mark-ring-goto]'."))) + (let ((pos (or pos (point))) + (buffer (or buffer (current-buffer)))) + (with-current-buffer buffer + (org-with-point-at pos (push-mark nil t))) + (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) + (move-marker (car org-mark-ring) pos buffer)) + (message + (substitute-command-keys + "Position saved to mark ring, go back with `\\[org-mark-ring-goto]'."))) (defun org-mark-ring-goto (&optional n) "Jump to the previous position in the mark ring. @@ -11128,11 +8850,6 @@ or to another Org file, automatically push the old position onto the ring." (goto-char m) (when (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) -(defun org-add-angle-brackets (s) - (unless (equal (substring s 0 1) "<") (setq s (concat "<" s))) - (unless (equal (substring s -1) ">") (setq s (concat s ">"))) - s) - ;;; Following specific links (defvar org-agenda-buffer-tmp-name) @@ -11165,223 +8882,6 @@ or to another Org file, automatically push the old position onto the ring." (declare-function mailcap-mime-info "mailcap" (string &optional request no-decode)) (defvar org-wait nil) -(defun org-open-file (path &optional in-emacs line search) - "Open the file at PATH. -First, this expands any special file name abbreviations. Then the -configuration variable `org-file-apps' is checked if it contains an -entry for this file type, and if yes, the corresponding command is launched. - -If no application is found, Emacs simply visits the file. - -With optional prefix argument IN-EMACS, Emacs will visit the file. -With a double \\[universal-argument] \\[universal-argument] \ -prefix arg, Org tries to avoid opening in Emacs -and to use an external application to visit the file. - -Optional LINE specifies a line to go to, optional SEARCH a string -to search for. If LINE or SEARCH is given, the file will be -opened in Emacs, unless an entry from org-file-apps that makes -use of groups in a regexp matches. - -If you want to change the way frames are used when following a -link, please customize `org-link-frame-setup'. - -If the file does not exist, an error is thrown." - (let* ((file (if (equal path "") - buffer-file-name - (substitute-in-file-name (expand-file-name path)))) - (file-apps (append org-file-apps (org-default-apps))) - (apps (cl-remove-if - 'org-file-apps-entry-match-against-dlink-p file-apps)) - (apps-dlink (cl-remove-if-not - 'org-file-apps-entry-match-against-dlink-p file-apps)) - (remp (and (assq 'remote apps) (org-file-remote-p file))) - (dirp (unless remp (file-directory-p file))) - (file (if (and dirp org-open-directory-means-index-dot-org) - (concat (file-name-as-directory file) "index.org") - file)) - (a-m-a-p (assq 'auto-mode apps)) - (dfile (downcase file)) - ;; Reconstruct the original link from the PATH, LINE and - ;; SEARCH args. - (link (cond (line (concat file "::" (number-to-string line))) - (search (concat file "::" search)) - (t file))) - (dlink (downcase link)) - (ext - (and (string-match "\\`.*?\\.\\([a-zA-Z0-9]+\\(\\.gz\\)?\\)\\'" dfile) - (match-string 1 dfile))) - (save-position-maybe - (let ((old-buffer (current-buffer)) - (old-pos (point)) - (old-mode major-mode)) - (lambda () - (and (derived-mode-p 'org-mode) - (eq old-mode 'org-mode) - (or (not (eq old-buffer (current-buffer))) - (not (eq old-pos (point)))) - (org-mark-ring-push old-pos old-buffer))))) - cmd link-match-data) - (cond - ((member in-emacs '((16) system)) - (setq cmd (cdr (assq 'system apps)))) - (in-emacs (setq cmd 'emacs)) - (t - (setq cmd (or (and remp (cdr (assq 'remote apps))) - (and dirp (cdr (assq 'directory apps))) - ;; First, try matching against apps-dlink if we - ;; get a match here, store the match data for - ;; later. - (let ((match (assoc-default dlink apps-dlink - 'string-match))) - (if match - (progn (setq link-match-data (match-data)) - match) - (progn (setq in-emacs (or in-emacs line search)) - nil))) ; if we have no match in apps-dlink, - ; always open the file in emacs if line or search - ; is given (for backwards compatibility) - (assoc-default dfile (org-apps-regexp-alist apps a-m-a-p) - 'string-match) - (cdr (assoc ext apps)) - (cdr (assq t apps)))))) - (when (eq cmd 'system) - (setq cmd (cdr (assq 'system apps)))) - (when (eq cmd 'default) - (setq cmd (cdr (assoc t apps)))) - (when (eq cmd 'mailcap) - (require 'mailcap) - (mailcap-parse-mailcaps) - (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) - (command (mailcap-mime-info mime-type))) - (if (stringp command) - (setq cmd command) - (setq cmd 'emacs)))) - (when (and (not (eq cmd 'emacs)) ; Emacs has no problems with non-ex files - (not (file-exists-p file)) - (not org-open-non-existing-files)) - (user-error "No such file: %s" file)) - (cond - ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) - ;; Remove quotes around the file name - we'll use shell-quote-argument. - (while (string-match "['\"]%s['\"]" cmd) - (setq cmd (replace-match "%s" t t cmd))) - (setq cmd (replace-regexp-in-string - "%s" - (shell-quote-argument (convert-standard-filename file)) - cmd - nil t)) - - ;; Replace "%1", "%2" etc. in command with group matches from regex - (save-match-data - (let ((match-index 1) - (number-of-groups (- (/ (length link-match-data) 2) 1))) - (set-match-data link-match-data) - (while (<= match-index number-of-groups) - (let ((regex (concat "%" (number-to-string match-index))) - (replace-with (match-string match-index dlink))) - (while (string-match regex cmd) - (setq cmd (replace-match replace-with t t cmd)))) - (setq match-index (+ match-index 1))))) - - (save-window-excursion - (message "Running %s...done" cmd) - (start-process-shell-command cmd nil cmd) - (and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait)))) - ((or (stringp cmd) - (eq cmd 'emacs)) - (funcall (cdr (assq 'file org-link-frame-setup)) file) - (widen) - (cond (line (org-goto-line line) - (when (derived-mode-p 'org-mode) (org-reveal))) - (search (condition-case err - (org-link-search search) - ;; Save position before error-ing out so user - ;; can easily move back to the original buffer. - (error (funcall save-position-maybe) - (error (nth 1 err))))))) - ((functionp cmd) - (save-match-data - (set-match-data link-match-data) - (condition-case nil - (funcall cmd file link) - ;; FIXME: Remove this check when most default installations - ;; of Emacs have at least Org 9.0. - ((debug wrong-number-of-arguments wrong-type-argument - invalid-function) - (user-error "Please see Org News for version 9.0 about \ -`org-file-apps'--Lisp error: %S" cmd))))) - ((consp cmd) - ;; FIXME: Remove this check when most default installations of - ;; Emacs have at least Org 9.0. Heads-up instead of silently - ;; fall back to `org-link-frame-setup' for an old usage of - ;; `org-file-apps' with sexp instead of a function for `cmd'. - (user-error "Please see Org News for version 9.0 about \ -`org-file-apps'--Error: Deprecated usage of %S" cmd)) - (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) - (funcall save-position-maybe))) - -(defun org-file-apps-entry-match-against-dlink-p (entry) - "This function returns non-nil if `entry' uses a regular -expression which should be matched against the whole link by -org-open-file. - -It assumes that is the case when the entry uses a regular -expression which has at least one grouping construct and the -action is either a lisp form or a command string containing -`%1', i.e. using at least one subexpression match as a -parameter." - (let ((selector (car entry)) - (action (cdr entry))) - (if (stringp selector) - (and (> (regexp-opt-depth selector) 0) - (or (and (stringp action) - (string-match "%[0-9]" action)) - (consp action))) - nil))) - -(defun org-default-apps () - "Return the default applications for this operating system." - (cond - ((eq system-type 'darwin) - org-file-apps-defaults-macosx) - ((eq system-type 'windows-nt) - org-file-apps-defaults-windowsnt) - (t org-file-apps-defaults-gnu))) - -(defun org-apps-regexp-alist (list &optional add-auto-mode) - "Convert extensions to regular expressions in the cars of LIST. -Also, weed out any non-string entries, because the return value is used -only for regexp matching. -When ADD-AUTO-MODE is set, make all matches in `auto-mode-alist' -point to the symbol `emacs', indicating that the file should -be opened in Emacs." - (append - (delq nil - (mapcar (lambda (x) - (unless (not (stringp (car x))) - (if (string-match "\\W" (car x)) - x - (cons (concat "\\." (car x) "\\'") (cdr x))))) - list)) - (when add-auto-mode - (mapcar (lambda (x) (cons (car x) 'emacs)) auto-mode-alist)))) - -(defvar ange-ftp-name-format) -(defun org-file-remote-p (file) - "Test whether FILE specifies a location on a remote system. -Return non-nil if the location is indeed remote. - -For example, the filename \"/user@host:/foo\" specifies a location -on the system \"/user@host:\"." - (cond ((fboundp 'file-remote-p) - (file-remote-p file)) - ((fboundp 'tramp-handle-file-remote-p) - (tramp-handle-file-remote-p file)) - ((and (boundp 'ange-ftp-name-format) - (string-match (car ange-ftp-name-format) file)) - t))) - ;;;; Refiling @@ -11554,7 +9054,7 @@ order.") (buffer-base-buffer)))) (_ nil)) (mapcar (lambda (s) (replace-regexp-in-string - "/" "\\/" s nil t)) + "/" "\\/" s nil t)) (org-get-outline-path t t))) "/")))) (push (list target f re (org-refile-marker (point))) @@ -11697,7 +9197,7 @@ the *old* location.") "Like `org-refile', but copy." (interactive) (let ((org-refile-keep t)) - (funcall 'org-refile nil nil nil "Copy"))) + (org-refile nil nil nil "Copy"))) (defun org-refile (&optional arg default-buffer rfloc msg) "Move the entry or entries at point to another heading. @@ -11753,7 +9253,7 @@ prefix argument (`C-u C-u C-u C-c C-w')." (setq last-command nil) (when regionp (goto-char region-start) - (or (bolp) (goto-char (point-at-bol))) + (beginning-of-line) (setq region-start (point)) (unless (or (org-kill-is-subtree-p (buffer-substring region-start region-end)) @@ -11782,8 +9282,8 @@ prefix argument (`C-u C-u C-u C-c C-w')." (org-back-to-heading t) (setq heading-text (replace-regexp-in-string - org-bracket-link-regexp - "\\3" + org-link-bracket-re + "\\2" (or (nth 4 (org-heading-components)) "")))) (org-refile-get-location @@ -11841,13 +9341,21 @@ prefix argument (`C-u C-u C-u C-c C-w')." (or (outline-next-heading) (goto-char (point-max))))) (unless (bolp) (newline)) (org-paste-subtree level nil nil t) - (when org-log-refile - (org-add-log-setup 'refile nil nil org-log-refile) - (unless (eq org-log-refile 'note) - (save-excursion (org-add-log-note)))) + ;; Record information, according to `org-log-refile'. + ;; Do not prompt for a note when refiling multiple + ;; headlines, however. Simply add a time stamp. + (cond + ((not org-log-refile)) + (regionp + (org-map-region + (lambda () (org-add-log-setup 'refile nil nil 'time)) + (point) + (+ (point) (- region-end region-start)))) + (t + (org-add-log-setup 'refile nil nil org-log-refile))) (and org-auto-align-tags (let ((org-loop-over-headlines-in-active-region nil)) - (org-set-tags nil t))) + (org-align-tags))) (let ((bookmark-name (plist-get org-bookmark-names-plist :last-refile))) (when bookmark-name @@ -11867,9 +9375,10 @@ prefix argument (`C-u C-u C-u C-c C-w')." (unless org-refile-keep (if regionp (delete-region (point) (+ (point) (- region-end region-start))) - (delete-region - (and (org-back-to-heading t) (point)) - (min (1+ (buffer-size)) (org-end-of-subtree t t) (point))))) + (org-preserve-local-variables + (delete-region + (and (org-back-to-heading t) (point)) + (min (1+ (buffer-size)) (org-end-of-subtree t t) (point)))))) (when (featurep 'org-inlinetask) (org-inlinetask-remove-END-maybe)) (setq org-markers-to-move nil) @@ -12097,6 +9606,42 @@ If COMMAND is not given, use `org-update-dblock'." (unless (re-search-forward org-dblock-end-re nil t) (error "Dynamic block not terminated")))))) +(defvar org-dynamic-block-alist nil + "Alist defining all the Org dynamic blocks. + +The key is the dynamic block type name, as a string. The value +is the function used to insert the dynamic block. + +Use `org-dynamic-block-define' to populate it.") + +(defun org-dynamic-block-function (type) + "Return function associated to a given dynamic block type. +TYPE is the dynamic block type, as a string." + (cdr (assoc type org-dynamic-block-alist))) + +(defun org-dynamic-block-types () + "List all defined dynamic block types." + (mapcar #'car org-dynamic-block-alist)) + +(defun org-dynamic-block-define (type func) + "Define dynamic block TYPE with FUNC. +TYPE is a string. FUNC is the function creating the dynamic +block of such type." + (pcase (assoc type org-dynamic-block-alist) + (`nil (push (cons type func) org-dynamic-block-alist)) + (def (setcdr def func)))) + +(defun org-dynamic-block-insert-dblock (type) + "Insert a dynamic block of type TYPE. +When used interactively, select the dynamic block types among +defined types, per `org-dynamic-block-define'." + (interactive (list (completing-read "Dynamic block: " + (org-dynamic-block-types)))) + (pcase (org-dynamic-block-function type) + (`nil (error "No such dynamic block: %S" type)) + ((and f (pred functionp)) (funcall f)) + (_ (error "Invalid function for dynamic block %S" type)))) + (defun org-dblock-update (&optional arg) "User command for updating dynamic blocks. Update the dynamic block at point. With prefix ARG, update all dynamic @@ -12186,76 +9731,188 @@ keywords relative to each registered export back-end." "TITLE:" "TODO:" "TYP_TODO:" "SELECT_TAGS:" "EXCLUDE_TAGS:")) (defcustom org-structure-template-alist - '(("s" "#+BEGIN_SRC ?\n\n#+END_SRC") - ("e" "#+BEGIN_EXAMPLE\n?\n#+END_EXAMPLE") - ("q" "#+BEGIN_QUOTE\n?\n#+END_QUOTE") - ("v" "#+BEGIN_VERSE\n?\n#+END_VERSE") - ("V" "#+BEGIN_VERBATIM\n?\n#+END_VERBATIM") - ("c" "#+BEGIN_CENTER\n?\n#+END_CENTER") - ("C" "#+BEGIN_COMMENT\n?\n#+END_COMMENT") - ("l" "#+BEGIN_EXPORT latex\n?\n#+END_EXPORT") - ("L" "#+LaTeX: ") - ("h" "#+BEGIN_EXPORT html\n?\n#+END_EXPORT") - ("H" "#+HTML: ") - ("a" "#+BEGIN_EXPORT ascii\n?\n#+END_EXPORT") - ("A" "#+ASCII: ") - ("i" "#+INDEX: ?") - ("I" "#+INCLUDE: %file ?")) - "Structure completion elements. -This is a list of abbreviation keys and values. The value gets inserted -if you type `<' followed by the key and then press the completion key, -usually `TAB'. %file will be replaced by a file name after prompting -for the file using completion. The cursor will be placed at the position -of the `?' in the template. -There are two templates for each key, the first uses the original Org syntax, -the second uses Emacs Muse-like syntax tags. These Muse-like tags become -the default when the /org-mtags.el/ module has been loaded. See also the -variable `org-mtags-prefer-muse-templates'." + '(("a" . "export ascii") + ("c" . "center") + ("C" . "comment") + ("e" . "example") + ("E" . "export") + ("h" . "export html") + ("l" . "export latex") + ("q" . "quote") + ("s" . "src") + ("v" . "verse")) + "An alist of keys and block types. +`org-insert-structure-template' will display a menu with this +list of templates to choose from. The block type is inserted, +with \"#+BEGIN_\" and \"#+END_\" added automatically. + +The menu keys are defined by the car of each entry in this alist. +If two entries have the keys \"a\" and \"aa\" respectively, the +former will be inserted by typing \"a TAB/RET/SPC\" and the +latter will be inserted by typing \"aa\". If an entry with the +key \"aab\" is later added, it can be inserted by typing \"ab\". + +If loaded, Org Tempo also uses `org-structure-template-alist'. A +block can be inserted by pressing TAB after the string \"<KEY\"." :group 'org-edit-structure :type '(repeat - (list - (string :tag "Key") - (string :tag "Template"))) - :version "26.1" - :package-version '(Org . "8.3")) + (cons (string :tag "Key") + (string :tag "Template"))) + :package-version '(Org . "9.2")) -(defun org-try-structure-completion () - "Try to complete a structure template before point. -This looks for strings like \"<e\" on an otherwise empty line and -expands them." - (let ((l (buffer-substring (point-at-bol) (point))) - a) - (when (and (looking-at "[ \t]*$") - (string-match "^[ \t]*<\\([a-zA-Z]+\\)$" l) - (setq a (assoc (match-string 1 l) org-structure-template-alist))) - (org-complete-expand-structure-template (+ -1 (point-at-bol) - (match-beginning 1)) a) - t))) +(defun org--check-org-structure-template-alist (&optional checklist) + "Check whether `org-structure-template-alist' is set up correctly. +In particular, check if the Org 9.2 format is used as opposed to +previous format. +" + (let ((elm (cl-remove-if-not (lambda (x) (listp (cdr x))) + (or (eval checklist) + org-structure-template-alist)))) + (when elm + (org-display-warning + (format " +Please update the entries of `%s'. + +In Org 9.2 the format was changed from something like + + (\"s\" \"#+BEGIN_SRC ?\\n#+END_SRC\") + +to something like + + (\"s\" . \"src\") + +Please refer to the documentation of `org-structure-template-alist'. + +The following entries must be updated: + +%s" + (or checklist 'org-structure-template-alist) + (pp-to-string elm)))))) + +(defun org--insert-structure-template-mks () + "Present `org-structure-template-alist' with `org-mks'. + +Menus are added if keys require more than one keystroke. Tabs +are added to single key entries when more than one stroke is +needed. Keys longer than two characters are reduced to two +characters." + (org--check-org-structure-template-alist) + (let* (case-fold-search + (templates (append org-structure-template-alist + '(("\t" . "Press TAB, RET or SPC to write block name")))) + (keys (mapcar #'car templates)) + (start-letters + (delete-dups (mapcar (lambda (key) (substring key 0 1)) keys))) + ;; Sort each element of `org-structure-template-alist' into + ;; sublists according to the first letter. + (superlist + (mapcar (lambda (letter) + (list letter + (cl-remove-if-not + (apply-partially #'string-match-p (concat "^" letter)) + templates :key #'car))) + start-letters))) + (org-mks + (apply #'append + ;; Make an `org-mks' table. If only one element is + ;; present in a sublist, make it part of the top-menu, + ;; otherwise make a submenu according to the starting + ;; letter and populate it. + (mapcar (lambda (sublist) + (if (eq 1 (length (cadr sublist))) + (mapcar (lambda (elm) + (list (substring (car elm) 0 1) + (cdr elm) "")) + (cadr sublist)) + ;; Create submenu. + (let* ((topkey (car sublist)) + (elms (cadr sublist)) + (keys (mapcar #'car elms)) + (long (> (length elms) 3))) + (append + (list + ;; Make a description of the submenu. + (list topkey + (concat + (mapconcat #'cdr + (cl-subseq elms 0 (if long 3 (length elms))) + ", ") + (when long ", ...")))) + ;; List of entries in submenu. + (cl-mapcar #'list + (org--insert-structure-template-unique-keys keys) + (mapcar #'cdr elms) + (make-list (length elms) "")))))) + superlist)) + "Select a key\n============" + "Key: "))) + +(defun org--insert-structure-template-unique-keys (keys) + "Make a list of unique, two characters long elements from KEYS. + +Elements of length one have a tab appended. Elements of length +two are kept as is. Longer elements are truncated to length two. + +If an element cannot be made unique, an error is raised." + (let ((orderd-keys (cl-sort (copy-sequence keys) #'< :key #'length)) + menu-keys) + (dolist (key orderd-keys) + (let ((potential-key + (cl-case (length key) + (1 (concat key "\t")) + (2 key) + (otherwise + (cl-find-if-not (lambda (k) (assoc k menu-keys)) + (mapcar (apply-partially #'concat (substring key 0 1)) + (split-string (substring key 1) "" t))))))) + (if (or (not potential-key) (assoc potential-key menu-keys)) + (user-error "Could not make unique key for %s." key) + (push (cons potential-key key) menu-keys)))) + (mapcar #'car + (cl-sort menu-keys #'< + :key (lambda (elm) (cl-position (cdr elm) keys)))))) + +(defun org-insert-structure-template (type) + "Insert a block structure of the type #+begin_foo/#+end_foo. +Select a block from `org-structure-template-alist' then type +either RET, TAB or SPC to write the block type. With an active +region, wrap the region in the block. Otherwise, insert an empty +block." + (interactive + (list (pcase (org--insert-structure-template-mks) + (`("\t" . ,_) (read-string "Structure type: ")) + (`(,_ ,choice . ,_) choice)))) + (let* ((region? (use-region-p)) + (region-start (and region? (region-beginning))) + (region-end (and region? (copy-marker (region-end)))) + (extended? (string-match-p "\\`\\(src\\|export\\)\\'" type)) + (verbatim? (string-match-p + (concat "\\`" (regexp-opt '("example" "export" "src"))) + type))) + (when region? (goto-char region-start)) + (let ((column (current-indentation))) + (if (save-excursion (skip-chars-backward " \t") (bolp)) + (beginning-of-line) + (insert "\n")) + (save-excursion + (indent-to column) + (insert (format "#+begin_%s%s\n" type (if extended? " " ""))) + (when region? + (when verbatim? (org-escape-code-in-region (point) region-end)) + (goto-char region-end) + ;; Ignore empty lines at the end of the region. + (skip-chars-backward " \r\t\n") + (end-of-line)) + (unless (bolp) (insert "\n")) + (indent-to column) + (insert (format "#+end_%s" (car (split-string type)))) + (if (looking-at "[ \t]*$") (replace-match "") + (insert "\n")) + (when (and (eobp) (not (bolp))) (insert "\n"))) + (if extended? (end-of-line) + (forward-line) + (skip-chars-forward " \t"))))) -(defun org-complete-expand-structure-template (start cell) - "Expand a structure template." - (let ((rpl (nth 1 cell)) - (ind "")) - (delete-region start (point)) - (when (string-match "\\`[ \t]*#\\+" rpl) - (cond - ((bolp)) - ((not (string-match "\\S-" (buffer-substring (point-at-bol) (point)))) - (setq ind (buffer-substring (point-at-bol) (point)))) - (t (newline)))) - (setq start (point)) - (when (string-match "%file" rpl) - (setq rpl (replace-match - (concat - "\"" - (save-match-data - (abbreviate-file-name (read-file-name "Include file: "))) - "\"") - t t rpl))) - (setq rpl (mapconcat 'identity (split-string rpl "\n") - (concat "\n" ind))) - (insert rpl) - (when (re-search-backward "\\?" start t) (delete-char 1)))) ;;;; TODO, DEADLINE, Comments @@ -12282,8 +9939,6 @@ expands them." If the last change removed the TODO tag or switched to DONE, then this is nil.") -(defvar org-setting-tags nil) ; dynamically skipped - (defvar org-todo-setup-filter-hook nil "Hook for functions that pre-filter todo specs. Each function takes a todo spec and returns either nil or the spec @@ -12353,15 +10008,20 @@ By default the available states are \"TODO\" and \"DONE\". So, for this example: when the item starts with TODO, it is changed to DONE. When it starts with DONE, the DONE is removed. And when neither TODO nor DONE are present, add TODO at the beginning of the heading. +You can set up single-charcter keys to fast-select the new state. See the +`org-todo-keywords' and `org-use-fast-todo-selection' for details. -With `\\[universal-argument]' prefix ARG, use completion to determine the new \ -state. -With numeric prefix ARG, switch to that state. +With `\\[universal-argument]' prefix ARG, force logging the state change \ +and take a +logging note. With a `\\[universal-argument] \\[universal-argument]' prefix, switch to the \ next set of TODO \ keywords (nextset). +Another way to achieve this is `S-C-<right>'. With a `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \ prefix, circumvent any state blocking. +With numeric prefix arg, switch to the Nth state. + With a numeric prefix arg of 0, inhibit note taking for the change. With a numeric prefix arg of -1, cancel repeater to allow marking as DONE. @@ -12404,6 +10064,7 @@ When called through ELisp, arg is also interpreted in the following way: (looking-at "\\(?: *\\|[ \t]*$\\)")) (let* ((match-data (match-data)) (startpos (copy-marker (line-beginning-position))) + (force-log (and (equal arg '(4)) (prog1 t (setq arg nil)))) (logging (save-match-data (org-entry-get nil "LOGGING" t t))) (org-log-done org-log-done) (org-log-repeat org-log-repeat) @@ -12423,34 +10084,19 @@ When called through ELisp, arg is also interpreted in the following way: (member (member this org-todo-keywords-1)) (tail (cdr member)) (org-state (cond - ((and org-todo-key-trigger - (or (and (equal arg '(4)) - (eq org-use-fast-todo-selection 'prefix)) - (and (not arg) org-use-fast-todo-selection - (not (eq org-use-fast-todo-selection - 'prefix))))) - ;; Use fast selection. - (org-fast-todo-selection)) - ((and (equal arg '(4)) - (or (not org-use-fast-todo-selection) - (not org-todo-key-trigger))) - ;; Read a state with completion. - (completing-read - "State: " (mapcar #'list org-todo-keywords-1) - nil t)) ((eq arg 'right) + ;; Next state (if this (if tail (car tail) nil) (car org-todo-keywords-1))) ((eq arg 'left) + ;; Previous state (unless (equal member org-todo-keywords-1) (if this (nth (- (length org-todo-keywords-1) (length tail) 2) org-todo-keywords-1) (org-last org-todo-keywords-1)))) - ((and (eq org-use-fast-todo-selection t) (equal arg '(4)) - (setq arg nil))) ;hack to fall back to cycling (arg ;; User or caller requests a specific state. (cond @@ -12469,6 +10115,9 @@ When called through ELisp, arg is also interpreted in the following way: (user-error "State `%s' not valid in this file" arg)) ((nth (1- (prefix-numeric-value arg)) org-todo-keywords-1)))) + ((and org-todo-key-trigger org-use-fast-todo-selection) + ;; Use fast selection. + (org-fast-todo-selection this)) ((null member) (or head (car org-todo-keywords-1))) ((equal this final-done-word) nil) ;-> make empty ((null tail) nil) ;-> first entry @@ -12484,7 +10133,7 @@ When called through ELisp, arg is also interpreted in the following way: (run-hook-with-args-until-success 'org-todo-get-default-hook org-state org-last-state) org-state)) - (next (if org-state (concat " " org-state " ") " ")) + (next (if (org-string-nw-p org-state) (concat " " org-state " ") " ")) (change-plist (list :type 'todo-state-change :from this :to org-state :position startpos)) dolog now-done-p) @@ -12530,11 +10179,13 @@ When called through ELisp, arg is also interpreted in the following way: (setq now-done-p (and (member org-state org-done-keywords) (not (member this org-done-keywords)))) (and logging (org-local-logging logging)) - (when (and (or org-todo-log-states org-log-done) - (not (eq org-inhibit-logging t)) - (not (memq arg '(nextset previousset)))) + (when (or (and (or org-todo-log-states org-log-done) + (not (eq org-inhibit-logging t)) + (not (memq arg '(nextset previousset)))) + force-log) ;; We need to look at recording a time and note. - (setq dolog (or (nth 1 (assoc org-state org-todo-log-states)) + (setq dolog (or (if force-log 'note) + (nth 1 (assoc org-state org-todo-log-states)) (nth 2 (assoc this org-todo-log-states)))) (when (and (eq dolog 'note) (eq org-inhibit-logging 'note)) (setq dolog 'time)) @@ -12555,9 +10206,11 @@ When called through ELisp, arg is also interpreted in the following way: (org-add-log-setup 'state org-state this dolog))) ;; Fixup tag positioning. (org-todo-trigger-tag-changes org-state) - (and org-auto-align-tags (not org-setting-tags) (org-set-tags nil t)) + (when org-auto-align-tags (org-align-tags)) (when org-provide-todo-statistics (org-update-parent-todo-statistics)) + (when (bound-and-true-p org-clock-out-when-done) + (org-clock-out-if-current)) (run-hooks 'org-after-todo-state-change-hook) (when (and arg (not (member org-state org-done-keywords))) (setq head (org-get-todo-sequence-head org-state))) @@ -12577,7 +10230,9 @@ When called through ELisp, arg is also interpreted in the following way: (looking-at org-todo-line-regexp)) (< (point) (+ 2 (or (match-end 2) (match-end 1))))) (goto-char (or (match-end 2) (match-end 1))) - (and (looking-at " ") (just-one-space))) + (and (looking-at " ") + (not (looking-at " *:")) + (just-one-space))) (when org-trigger-hook (save-excursion (run-hook-with-args 'org-trigger-hook change-plist))) @@ -12934,25 +10589,31 @@ right sequence." (car org-todo-keywords-1)) (t (nth 2 (assoc kwd org-todo-kwd-alist)))))) -(defun org-fast-todo-selection () +(defun org-fast-todo-selection (&optional current-state) "Fast TODO keyword selection with single keys. -Returns the new TODO keyword, or nil if no state change should occur." +Returns the new TODO keyword, or nil if no state change should occur. +When CURRENT-STATE is given and selection letters are not unique globally, +prefer a state in the current sequence over on in another sequence." (let* ((fulltable org-todo-key-alist) + (head (org-get-todo-sequence-head current-state)) (done-keywords org-done-keywords) ;; needed for the faces. (maxlen (apply 'max (mapcar (lambda (x) (if (stringp (car x)) (string-width (car x)) 0)) fulltable))) - (expert nil) + (expert (equal org-use-fast-todo-selection 'expert)) + (prompt "") (fwidth (+ maxlen 3 1 3)) (ncol (/ (- (window-width) 4) fwidth)) - tg cnt e c tbl - groups ingroup) + tg cnt e c tbl subtable + groups ingroup in-current-sequence) (save-excursion (save-window-excursion (if expert (set-buffer (get-buffer-create " *Org todo*")) - (org-switch-to-buffer-other-window (get-buffer-create " *Org todo*"))) + (delete-other-windows) + (set-window-buffer (split-window-vertically) (get-buffer-create " *Org todo*")) + (org-switch-to-buffer-other-window " *Org todo*")) (erase-buffer) (setq-local org-done-keywords done-keywords) (setq tbl fulltable cnt 0) @@ -12963,9 +10624,11 @@ Returns the new TODO keyword, or nil if no state change should occur." (unless (= cnt 0) (setq cnt 0) (insert "\n")) + (setq prompt (concat prompt "{")) (insert "{ ")) ((equal e '(:endgroup)) - (setq ingroup nil cnt 0) + (setq ingroup nil cnt 0 in-current-sequence nil) + (setq prompt (concat prompt "}")) (insert "}\n")) ((equal e '(:newline)) (unless (= cnt 0) @@ -12977,27 +10640,35 @@ Returns the new TODO keyword, or nil if no state change should occur." (setq tbl (cdr tbl))))) (t (setq tg (car e) c (cdr e)) + (if (equal tg head) (setq in-current-sequence t)) (when ingroup (push tg (car groups))) + (when in-current-sequence (push e subtable)) (setq tg (org-add-props tg nil 'face (org-get-todo-face tg))) (when (and (= cnt 0) (not ingroup)) (insert " ")) + (setq prompt (concat prompt "[" (char-to-string c) "] " tg " ")) (insert "[" c "] " tg (make-string (- fwidth 4 (length tg)) ?\ )) - (when (= (setq cnt (1+ cnt)) ncol) + (when (and (= (setq cnt (1+ cnt)) ncol) + ;; Avoid lines with just a closing delimiter. + (not (equal (car tbl) '(:endgroup)))) (insert "\n") (when ingroup (insert " ")) (setq cnt 0))))) (insert "\n") (goto-char (point-min)) (unless expert (org-fit-window-to-buffer)) - (message "[a-z..]:Set [SPC]:clear") + (message (concat "[a-z..]:Set [SPC]:clear" + (if expert (concat "\n" prompt) ""))) (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (setq subtable (nreverse subtable)) (cond ((or (= c ?\C-g) (and (= c ?q) (not (rassoc c fulltable)))) (setq quit-flag t)) ((= c ?\ ) nil) - ((setq e (rassoc c fulltable) tg (car e)) + ((setq e (or (rassoc c subtable) (rassoc c fulltable)) + tg (car e)) tg) (t (setq quit-flag t))))))) @@ -13084,114 +10755,109 @@ This function is run automatically after each state change to a DONE state." (org-log-done nil) (org-todo-log-states nil) (end (copy-marker (org-entry-end-position)))) - (unwind-protect - (when (and repeat (not (zerop (string-to-number (substring repeat 1))))) - (when (eq org-log-repeat t) (setq org-log-repeat 'state)) - (let ((to-state (or (org-entry-get nil "REPEAT_TO_STATE" 'selective) - org-todo-repeat-to-state))) - (org-todo (cond - ((and to-state (member to-state org-todo-keywords-1)) - to-state) - ((eq interpret 'type) org-last-state) - (head) - (t 'none)))) - (org-back-to-heading t) - (org-add-planning-info nil nil 'closed) - ;; When `org-log-repeat' is non-nil or entry contains - ;; a clock, set LAST_REPEAT property. - (when (or org-log-repeat - (catch :clock - (save-excursion - (while (re-search-forward org-clock-line-re end t) - (when (org-at-clock-log-p) (throw :clock t)))))) - (org-entry-put nil "LAST_REPEAT" (format-time-string - (org-time-stamp-format t t)))) - (when org-log-repeat - (if (or (memq 'org-add-log-note (default-value 'post-command-hook)) - (memq 'org-add-log-note post-command-hook)) - ;; We are already setup for some record. - (when (eq org-log-repeat 'note) - ;; Make sure we take a note, not only a time stamp. - (setq org-log-note-how 'note)) - ;; Set up for taking a record. - (org-add-log-setup 'state - (or done-word (car org-done-keywords)) - org-last-state - org-log-repeat))) - (let ((planning-re (regexp-opt - (list org-scheduled-string org-deadline-string)))) - (while (re-search-forward org-ts-regexp end t) - (let* ((ts (match-string 0)) - (planning? (org-at-planning-p)) - (type (if (not planning?) "Plain:" - (save-excursion - (re-search-backward - planning-re (line-beginning-position) t) - (match-string 0))))) - (cond - ;; Ignore fake time-stamps (e.g., within comments). - ((not (org-at-timestamp-p 'agenda))) - ;; Time-stamps without a repeater are usually - ;; skipped. However, a SCHEDULED time-stamp without - ;; one is removed, as they are no longer relevant. - ((not (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)" - ts)) - (when (equal type org-scheduled-string) - (org-remove-timestamp-with-keyword type))) - (t - (let ((n (string-to-number (match-string 2 ts))) - (what (match-string 3 ts))) - (when (equal what "w") (setq n (* n 7) what "d")) - (when (and (equal what "h") - (not (string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" - ts))) - (user-error - "Cannot repeat in Repeat in %d hour(s) because no hour \ -has been set" - n)) - ;; Preparation, see if we need to modify the start - ;; date for the change. - (when (match-end 1) - (let ((time (save-match-data - (org-time-string-to-time ts)))) - (cond - ((equal (match-string 1 ts) ".") - ;; Shift starting date to today - (org-timestamp-change - (- (org-today) (time-to-days time)) - 'day)) - ((equal (match-string 1 ts) "+") - (let ((nshiftmax 10) - (nshift 0)) - (while (or (= nshift 0) - (not (time-less-p nil time))) - (when (= (cl-incf nshift) nshiftmax) - (or (y-or-n-p - (format "%d repeater intervals were not \ + (when (and repeat (not (= 0 (string-to-number (substring repeat 1))))) + (when (eq org-log-repeat t) (setq org-log-repeat 'state)) + (let ((to-state (or (org-entry-get nil "REPEAT_TO_STATE" 'selective) + (and (stringp org-todo-repeat-to-state) + org-todo-repeat-to-state) + (and org-todo-repeat-to-state org-last-state)))) + (org-todo (cond ((and to-state (member to-state org-todo-keywords-1)) + to-state) + ((eq interpret 'type) org-last-state) + (head) + (t 'none)))) + (org-back-to-heading t) + (org-add-planning-info nil nil 'closed) + ;; When `org-log-repeat' is non-nil or entry contains + ;; a clock, set LAST_REPEAT property. + (when (or org-log-repeat + (catch :clock + (save-excursion + (while (re-search-forward org-clock-line-re end t) + (when (org-at-clock-log-p) (throw :clock t)))))) + (org-entry-put nil "LAST_REPEAT" (format-time-string + (org-time-stamp-format t t)))) + (when org-log-repeat + (if (or (memq 'org-add-log-note (default-value 'post-command-hook)) + (memq 'org-add-log-note post-command-hook)) + ;; We are already setup for some record. + (when (eq org-log-repeat 'note) + ;; Make sure we take a note, not only a time stamp. + (setq org-log-note-how 'note)) + ;; Set up for taking a record. + (org-add-log-setup 'state + (or done-word (car org-done-keywords)) + org-last-state + org-log-repeat))) + ;; Time-stamps without a repeater are usually skipped. However, + ;; a SCHEDULED time-stamp without one is removed, as they are no + ;; longer relevant. + (save-excursion + (let ((scheduled (org-entry-get (point) "SCHEDULED"))) + (when (and scheduled (not (string-match-p org-repeat-re scheduled))) + (org-remove-timestamp-with-keyword org-scheduled-string)))) + ;; Update every time-stamp with a repeater in the entry. + (let ((planning-re (regexp-opt + (list org-scheduled-string org-deadline-string)))) + (while (re-search-forward org-repeat-re end t) + (let* ((ts (match-string 0)) + (type (if (not (org-at-planning-p)) "Plain:" + (save-excursion + (re-search-backward + planning-re (line-beginning-position) t) + (match-string 0))))) + (when (and (org-at-timestamp-p 'agenda) + (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)" ts)) + (let ((n (string-to-number (match-string 2 ts))) + (what (match-string 3 ts))) + (when (equal what "w") (setq n (* n 7) what "d")) + (when (and (equal what "h") + (not (string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" + ts))) + (user-error + "Cannot repeat in %d hour(s) because no hour has been set" + n)) + ;; Preparation, see if we need to modify the start + ;; date for the change. + (when (match-end 1) + (let ((time (save-match-data (org-time-string-to-time ts))) + (repeater-type (match-string 1 ts))) + (cond + ((equal "." repeater-type) + ;; Shift starting date to today. + (org-timestamp-change (- (org-today) (time-to-days time)) + 'day)) + ((equal "+" repeater-type) + (let ((nshiftmax 10) + (nshift 0)) + (while (or (= nshift 0) + (not (org-time-less-p nil time))) + (when (= nshiftmax (cl-incf nshift)) + (or (y-or-n-p + (format "%d repeater intervals were not \ enough to shift date past today. Continue? " - nshift)) - (user-error "Abort"))) - (org-timestamp-change n (cdr (assoc what whata))) - (org-in-regexp org-ts-regexp3) - (setq ts (match-string 1)) - (setq time - (save-match-data - (org-time-string-to-time ts))))) - (org-timestamp-change (- n) (cdr (assoc what whata))) - ;; Rematch, so that we have everything in place - ;; for the real shift. + nshift)) + (user-error "Abort"))) + (org-timestamp-change n (cdr (assoc what whata))) (org-in-regexp org-ts-regexp3) (setq ts (match-string 1)) - (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)" - ts))))) - (save-excursion - (org-timestamp-change n (cdr (assoc what whata)) nil t)) - (setq msg - (concat - msg type " " org-last-changed-timestamp " ")))))))) - (setq org-log-post-message msg) - (message "%s" msg)) - (set-marker end nil)))) + (setq time + (save-match-data + (org-time-string-to-time ts))))) + (org-timestamp-change (- n) (cdr (assoc what whata))) + ;; Rematch, so that we have everything in place + ;; for the real shift. + (org-in-regexp org-ts-regexp3) + (setq ts (match-string 1)) + (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)" + ts))))) + (save-excursion + (org-timestamp-change n (cdr (assoc what whata)) nil t)) + (setq msg + (concat msg type " " org-last-changed-timestamp " "))))))) + (run-hooks 'org-todo-repeat-hook) + (setq org-log-post-message msg) + (message msg)))) (defun org-show-todo-tree (arg) "Make a compact tree which shows all headlines marked with TODO. @@ -13203,7 +10869,7 @@ of `org-todo-keywords-1'." (interactive "P") (let ((case-fold-search nil) (kwd-re - (cond ((null arg) org-not-done-regexp) + (cond ((null arg) (concat org-not-done-regexp "\\s-")) ((equal arg '(4)) (let ((kwd (completing-read "Keyword (or KWD1|KWD2|...): " @@ -13243,12 +10909,15 @@ TYPE is either `deadline' or `scheduled'. See `org-deadline' or (match-string 1 old-date))))) (pcase arg (`(4) - (when (and old-date log) - (org-add-log-setup (if deadline? 'deldeadline 'delschedule) - nil old-date log)) - (org-remove-timestamp-with-keyword keyword) - (message (if deadline? "Item no longer has a deadline." - "Item is no longer scheduled."))) + (if (not old-date) + (message (if deadline? "Entry had no deadline to remove" + "Entry was not scheduled")) + (when (and old-date log) + (org-add-log-setup (if deadline? 'deldeadline 'delschedule) + nil old-date log)) + (org-remove-timestamp-with-keyword keyword) + (message (if deadline? "Entry no longer has a deadline." + "Entry is no longer scheduled.")))) (`(16) (save-excursion (org-back-to-heading t) @@ -13413,9 +11082,12 @@ WHAT entry will also be removed." (org-read-date-analyze time default-time (decode-time default-time))) ;; If necessary, get the time from the user - (or time (org-read-date nil 'to-time nil nil + (or time (org-read-date nil 'to-time nil + (cl-case what + (deadline "DEADLINE") + (scheduled "SCHEDULED") + (otherwise nil)) default-time default-input))))) - (org-with-wide-buffer (org-back-to-heading t) (forward-line) @@ -13527,7 +11199,9 @@ narrowing." (unless (bolp) (insert "\n")) (let ((beg (point))) (insert ":" drawer ":\n:END:\n") - (org-indent-region beg (point))) + (org-indent-region beg (point)) + (org-flag-region + (line-end-position -1) (1- (point)) t 'org-hide-drawer)) (end-of-line -1))))) (t (org-end-of-meta-data org-log-state-notes-insert-after-drawers) @@ -13566,8 +11240,8 @@ EXTRA is additional text that will be inserted into the notes buffer." (regexp-quote (cdr (assq 'state org-log-note-headings))) `(("%d" . ,org-ts-regexp-inactive) ("%D" . ,org-ts-regexp) - ("%s" . "\"\\S-+\"") - ("%S" . "\"\\S-+\"") + ("%s" . "\\(?:\"\\S-+\"\\)?") + ("%S" . "\\(?:\"\\S-+\"\\)?") ("%t" . ,org-ts-regexp-inactive) ("%T" . ,org-ts-regexp) ("%u" . ".*?") @@ -13591,26 +11265,20 @@ EXTRA is additional text that will be inserted into the notes buffer." (let ((org-inhibit-startup t)) (org-mode)) (insert (format "# Insert note for %s. # Finish with C-c C-c, or cancel with C-c C-k.\n\n" - (cond - ((eq org-log-note-purpose 'clock-out) "stopped clock") - ((eq org-log-note-purpose 'done) "closed todo item") - ((eq org-log-note-purpose 'state) - (format "state change from \"%s\" to \"%s\"" - (or org-log-note-previous-state "") - (or org-log-note-state ""))) - ((eq org-log-note-purpose 'reschedule) - "rescheduling") - ((eq org-log-note-purpose 'delschedule) - "no longer scheduled") - ((eq org-log-note-purpose 'redeadline) - "changing deadline") - ((eq org-log-note-purpose 'deldeadline) - "removing deadline") - ((eq org-log-note-purpose 'refile) - "refiling") - ((eq org-log-note-purpose 'note) - "this entry") - (t (error "This should not happen"))))) + (cl-case org-log-note-purpose + (clock-out "stopped clock") + (done "closed todo item") + (reschedule "rescheduling") + (delschedule "no longer scheduled") + (redeadline "changing deadline") + (deldeadline "removing deadline") + (refile "refiling") + (note "this entry") + (state + (format "state change from \"%s\" to \"%s\"" + (or org-log-note-previous-state "") + (or org-log-note-state ""))) + (t (error "This should not happen"))))) (when org-log-note-extra (insert org-log-note-extra)) (setq-local org-finish-function 'org-store-log-note) (run-hooks 'org-log-buffer-setup-hook))) @@ -13693,8 +11361,7 @@ EXTRA is additional text that will be inserted into the notes buffer." (indent-line-to ind) (insert line))) (message "Note stored") - (org-back-to-heading t) - (org-cycle-hide-drawers 'children)) + (org-back-to-heading t)) ;; Fix `buffer-undo-list' when `org-store-log-note' is called ;; from within `org-add-log-note' because `buffer-undo-list' ;; is then modified outside of `org-with-remote-undo'. @@ -13864,74 +11531,6 @@ match is found." (goto-char p1) (user-error "No more matches")))) -(defun org-show-context (&optional key) - "Make sure point and context are visible. -Optional argument KEY, when non-nil, is a symbol. See -`org-show-context-detail' for allowed values and how much is to -be shown." - (org-show-set-visibility - (cond ((symbolp org-show-context-detail) org-show-context-detail) - ((cdr (assq key org-show-context-detail))) - (t (cdr (assq 'default org-show-context-detail)))))) - -(defun org-show-set-visibility (detail) - "Set visibility around point according to DETAIL. -DETAIL is either nil, `minimal', `local', `ancestors', `lineage', -`tree', `canonical' or t. See `org-show-context-detail' for more -information." - ;; Show current heading and possibly its entry, following headline - ;; or all children. - (if (and (org-at-heading-p) (not (eq detail 'local))) - (org-flag-heading nil) - (org-show-entry) - ;; If point is hidden within a drawer or a block, make sure to - ;; expose it. - (dolist (o (overlays-at (point))) - (when (memq (overlay-get o 'invisible) '(org-hide-block outline)) - (delete-overlay o))) - (unless (org-before-first-heading-p) - (org-with-limited-levels - (cl-case detail - ((tree canonical t) (org-show-children)) - ((nil minimal ancestors)) - (t (save-excursion - (outline-next-heading) - (org-flag-heading nil))))))) - ;; Show all siblings. - (when (eq detail 'lineage) (org-show-siblings)) - ;; Show ancestors, possibly with their children. - (when (memq detail '(ancestors lineage tree canonical t)) - (save-excursion - (while (org-up-heading-safe) - (org-flag-heading nil) - (when (memq detail '(canonical t)) (org-show-entry)) - (when (memq detail '(tree canonical t)) (org-show-children)))))) - -(defvar org-reveal-start-hook nil - "Hook run before revealing a location.") - -(defun org-reveal (&optional siblings) - "Show current entry, hierarchy above it, and the following headline. - -This can be used to show a consistent set of context around -locations exposed with `org-show-context'. - -With optional argument SIBLINGS, on each level of the hierarchy all -siblings are shown. This repairs the tree structure to what it would -look like when opened with hierarchical calls to `org-cycle'. - -With a \\[universal-argument] \\[universal-argument] prefix, \ -go to the parent and show the entire tree." - (interactive "P") - (run-hooks 'org-reveal-start-hook) - (cond ((equal siblings '(4)) (org-show-set-visibility 'canonical)) - ((equal siblings '(16)) - (save-excursion - (when (org-up-heading-safe) - (org-show-subtree) - (run-hook-with-args 'org-cycle-hook 'subtree)))) - (t (org-show-set-visibility 'lineage)))) - (defun org-highlight-new-match (beg end) "Highlight from BEG to END and mark the highlight is an occur headline." (let ((ov (make-overlay beg end))) @@ -13969,10 +11568,19 @@ from the `before-change-functions' in the current buffer." (interactive) (org-priority 'down)) -(defun org-priority (&optional action _show) +(defun org-priority (&optional action show) "Change the priority of an item. -ACTION can be `set', `up', `down', or a character." + +When called interactively with a `\\[universal-argument]' prefix, +show the priority in the minibuffer instead of changing it. + +When called programmatically, ACTION can be `set', `up', `down', +or a character." (interactive "P") + (when show + ;; Deprecation warning inserted for Org 9.2; once enough time has + ;; passed the SHOW argument should be removed. + (warn "`org-priority' called with deprecated SHOW argument")) (if (equal action '(4)) (org-show-priority) (unless org-enable-priority-commands @@ -13998,7 +11606,7 @@ ACTION can be `set', `up', `down', or a character." (when (and (= (upcase org-highest-priority) org-highest-priority) (= (upcase org-lowest-priority) org-lowest-priority)) (setq new (upcase new))) - (cond ((equal new ?\ ) (setq remove t)) + (cond ((equal new ?\s) (setq remove t)) ((or (< (upcase new) org-highest-priority) (> (upcase new) org-lowest-priority)) (user-error "Priority must be between `%c' and `%c'" org-highest-priority org-lowest-priority)))) @@ -14047,7 +11655,7 @@ ACTION can be `set', `up', `down', or a character." (insert " [#" news "]")) (goto-char (match-beginning 3)) (insert "[#" news "] ")))) - (org-set-tags nil 'align)) + (org-align-tags)) (if remove (message "Priority removed") (message "Priority of current item set to %s" news))))) @@ -14070,7 +11678,7 @@ and by additional input from the age of a schedules or deadline entry." "Find priority cookie and return priority." (save-match-data (if (functionp org-get-priority-function) - (funcall org-get-priority-function) + (funcall org-get-priority-function s) (if (not (string-match org-priority-regexp s)) (* 1000 (- org-lowest-priority org-default-priority)) (* 1000 (- org-lowest-priority @@ -14087,9 +11695,9 @@ Can be set by the action argument to `org-scan-tags' and `org-map-entries'.") "The current tag list while the tags scanner is running.") (defvar org-trust-scanner-tags nil - "Should `org-get-tags-at' use the tags for the scanner. + "Should `org-get-tags' use the tags for the scanner. This is for internal dynamical scoping only. -When this is non-nil, the function `org-get-tags-at' will return the value +When this is non-nil, the function `org-get-tags' will return the value of `org-scanner-tags' instead of building the list by itself. This can lead to large speed-ups when the tags scanner is used in a file with many entries, and when the list of tags is retrieved, for example to @@ -14124,9 +11732,8 @@ headlines matching this string." ;; Get the correct level to match (concat "\\*\\{" (number-to-string start-level) "\\} ") org-outline-regexp) - " *\\(\\<\\(" - (mapconcat #'regexp-quote org-todo-keywords-1 "\\|") - "\\)\\>\\)? *\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$")) + " *\\(" (regexp-opt org-todo-keywords-1 'words) "\\)?" + " *\\(.*?\\)\\([ \t]:\\(?:" org-tag-re ":\\)+\\)?[ \t]*$")) (props (list 'face 'default 'done-face 'org-agenda-done 'undone-face 'default @@ -14156,10 +11763,11 @@ headlines matching this string." (re-search-forward re nil t)) (setq org-map-continue-from nil) (catch :skip - (setq todo - ;; TODO: is the 1-2 difference a bug? - (when (match-end 1) (match-string-no-properties 2)) - tags (when (match-end 4) (match-string-no-properties 4))) + ;; Ignore closing parts of inline tasks. + (when (and (fboundp 'org-inlinetask-end-p) (org-inlinetask-end-p)) + (throw :skip t)) + (setq todo (and (match-end 1) (match-string-no-properties 1))) + (setq tags (and (match-end 4) (org-trim (match-string-no-properties 4)))) (goto-char (setq lspos (match-beginning 0))) (setq level (org-reduced-level (org-outline-level)) category (org-get-category)) @@ -14331,7 +11939,7 @@ instead of the agenda files." (mapcar (lambda (file) (set-buffer (find-file-noselect file)) - (org-tag-add-to-alist + (org--tag-add-to-alist (org-get-buffer-tags) (mapcar (lambda (x) (and (stringp (car-safe x)) @@ -14363,7 +11971,7 @@ See also `org-scan-tags'." ;; Get a new match request, with completion against the global ;; tags table and the local tags in current buffer. (let ((org-last-tags-completion-table - (org-tag-add-to-alist + (org--tag-add-to-alist (org-get-buffer-tags) (org-global-tags-completion-table)))) (setq match @@ -14372,7 +11980,12 @@ See also `org-scan-tags'." 'org-tags-completion-function nil nil nil 'org-tags-history)))) (let ((match0 match) - (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)\\([<>=]\\{1,2\\}\\)\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)\\|[[:alnum:]_@#%]+\\)") + (re (concat + "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)" + "\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)" + "\\([<>=]\\{1,2\\}\\)" + "\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)" + "\\|" org-tag-re "\\)")) (start 0) tagsmatch todomatch tagsmatcher todomatcher) @@ -14441,7 +12054,7 @@ See also `org-scan-tags'." (if timep 'time strp)))) (setq pv (if (or regexp strp) (substring pv 1 -1) pv)) (when timep (setq pv (org-matcher-time pv))) - (cond ((and regexp (eq po 'org<>)) + (cond ((and regexp (eq po '/=)) `(not (string-match ,pv (or ,gv "")))) (regexp `(string-match ,pv (or ,gv ""))) (strp `(,po (or ,gv "") ,pv)) @@ -14486,7 +12099,20 @@ See also `org-scan-tags'." (setq matcher `(and (member todo org-not-done-keywords) ,matcher))) (cons match0 `(lambda (todo tags-list level) ,matcher))))) -(defun org-tags-expand (match &optional single-as-list downcased tags-already-expanded) +(defun org--tags-expand-group (group tag-groups expanded) + "Recursively Expand all tags in GROUP, according to TAG-GROUPS. +TAG-GROUPS is the list of groups used for expansion. EXPANDED is +an accumulator used in recursive calls." + (dolist (tag group) + (unless (member tag expanded) + (let ((group (assoc tag tag-groups))) + (push tag expanded) + (when group + (setq expanded + (org--tags-expand-group (cdr group) tag-groups expanded)))))) + expanded) + +(defun org-tags-expand (match &optional single-as-list downcased) "Expand group tags in MATCH. This replaces every group tag in MATCH with a regexp tag search. @@ -14503,7 +12129,7 @@ E.g., this expansion Work|Home => {\\(?:Work\\|Lab\\|Conf\\}|Home will match anything tagged with \"Lab\" and \"Home\", or tagged -with \"Conf\" and \"Home\" or tagged with \"Work\" and \"home\". +with \"Conf\" and \"Home\" or tagged with \"Work\" and \"Home\". A group tag in MATCH can contain regular expressions of its own. For example, a group tag \"Proj\" defined as { Proj : {P@.+} } @@ -14515,240 +12141,78 @@ When the optional argument SINGLE-AS-LIST is non-nil, MATCH is assumed to be a single group tag, and the function will return the list of tags in this group. -When DOWNCASE is non-nil, expand downcased TAGS." - (if org-group-tags +When DOWNCASED is non-nil, expand downcased TAGS." + (unless (org-string-nw-p match) (error "Invalid match tag: %S" match)) + (let ((tag-groups + (let ((g (or org-tag-groups-alist-for-agenda org-tag-groups-alist))) + (if (not downcased) g + (mapcar (lambda (s) (mapcar #'downcase s)) g))))) + (cond + (single-as-list (org--tags-expand-group (list match) tag-groups nil)) + (org-group-tags (let* ((case-fold-search t) - (stable org-mode-syntax-table) - (taggroups (or org-tag-groups-alist-for-agenda org-tag-groups-alist)) - (taggroups (if downcased - (mapcar (lambda (tg) (mapcar #'downcase tg)) - taggroups) - taggroups)) - (taggroups-keys (mapcar #'car taggroups)) - (return-match (if downcased (downcase match) match)) - (count 0) - (work-already-expanded tags-already-expanded) - regexps-in-match tags-in-group regexp-in-group regexp-in-group-escaped) + (tag-syntax org-mode-syntax-table) + (group-keys (mapcar #'car tag-groups)) + (key-regexp (concat "\\([+-]?\\)" (regexp-opt group-keys 'words))) + (return-match (if downcased (downcase match) match))) + ;; Mark regexp-expressions in the match-expression so that we + ;; do not replace them later on. + (let ((s 0)) + (while (string-match "{.+?}" return-match s) + (setq s (match-end 0)) + (add-text-properties + (match-beginning 0) (match-end 0) '(regexp t) return-match))) ;; @ and _ are allowed as word-components in tags. - (modify-syntax-entry ?@ "w" stable) - (modify-syntax-entry ?_ "w" stable) - ;; Temporarily replace regexp-expressions in the match-expression. - (while (string-match "{.+?}" return-match) - (cl-incf count) - (push (match-string 0 return-match) regexps-in-match) - (setq return-match (replace-match (format "<%d>" count) t nil return-match))) - (while (and taggroups-keys - (with-syntax-table stable - (string-match - (concat "\\(?1:[+-]?\\)\\(?2:\\<" - (regexp-opt taggroups-keys) "\\>\\)") - return-match))) - (let* ((dir (match-string 1 return-match)) - (tag (match-string 2 return-match)) - (tag (if downcased (downcase tag) tag))) - (unless (or (get-text-property 0 'grouptag (match-string 2 return-match)) - (member tag tags-already-expanded)) - (setq tags-in-group (assoc tag taggroups)) - (push tag work-already-expanded) - ;; Recursively expand each tag in the group, if the tag hasn't - ;; already been expanded. Restore the match-data after all recursive calls. - (save-match-data - (let (tags-expanded) - (dolist (x (cdr tags-in-group)) - (if (and (member x taggroups-keys) - (not (member x work-already-expanded))) - (setq tags-expanded - (delete-dups - (append - (org-tags-expand x t downcased - work-already-expanded) - tags-expanded))) - (setq tags-expanded - (append (list x) tags-expanded))) - (setq work-already-expanded - (delete-dups - (append tags-expanded - work-already-expanded)))) - (setq tags-in-group - (delete-dups (cons (car tags-in-group) - tags-expanded))))) - ;; Filter tag-regexps from tags. - (setq regexp-in-group-escaped - (delq nil (mapcar (lambda (x) - (if (stringp x) - (and (equal "{" (substring x 0 1)) - (equal "}" (substring x -1)) - x) - x)) - tags-in-group)) - regexp-in-group - (mapcar (lambda (x) - (substring x 1 -1)) - regexp-in-group-escaped) - tags-in-group - (delq nil (mapcar (lambda (x) - (if (stringp x) - (and (not (equal "{" (substring x 0 1))) - (not (equal "}" (substring x -1))) - x) - x)) - tags-in-group))) - ;; If single-as-list, do no more in the while-loop. - (if (not single-as-list) - (progn - (when regexp-in-group - (setq regexp-in-group - (concat "\\|" - (mapconcat 'identity regexp-in-group - "\\|")))) - (setq tags-in-group - (concat dir - "{\\<" - (regexp-opt tags-in-group) - "\\>" - regexp-in-group - "}")) - (when (stringp tags-in-group) - (org-add-props tags-in-group '(grouptag t))) - (setq return-match - (replace-match tags-in-group t t return-match))) - (setq tags-in-group - (append regexp-in-group-escaped tags-in-group)))) - (setq taggroups-keys (delete tag taggroups-keys)))) - ;; Add the regular expressions back into the match-expression again. - (while regexps-in-match - (setq return-match (replace-regexp-in-string (format "<%d>" count) - (pop regexps-in-match) - return-match t t)) - (cl-decf count)) - (if single-as-list - (if tags-in-group tags-in-group (list return-match)) - return-match)) - (if single-as-list - (list (if downcased (downcase match) match)) - match))) + (modify-syntax-entry ?@ "w" tag-syntax) + (modify-syntax-entry ?_ "w" tag-syntax) + ;; For each tag token found in MATCH, compute a regexp and it + (with-syntax-table tag-syntax + (replace-regexp-in-string + key-regexp + (lambda (m) + (if (get-text-property (match-beginning 2) 'regexp m) + m ;regexp tag: ignore + (let* ((operator (match-string 1 m)) + (tag-token (let ((tag (match-string 2 m))) + (list (if downcased (downcase tag) tag)))) + regexp-tags regular-tags) + ;; Partition tags between regexp and regular tags. + ;; Remove curly bracket syntax from regexp tags. + (dolist (tag (org--tags-expand-group tag-token tag-groups nil)) + (save-match-data + (if (string-match "{\\(.+?\\)}" tag) + (push (match-string 1 tag) regexp-tags) + (push tag regular-tags)))) + ;; Replace tag token by the appropriate regexp. + ;; Regular tags need to be regexp-quoted, whereas + ;; regexp-tags are inserted as-is. + (let ((regular (regexp-opt regular-tags)) + (regexp (mapconcat #'identity regexp-tags "\\|"))) + (concat operator + (cond + ((null regular-tags) (format "{%s}" regexp)) + ((null regexp-tags) (format "{\\<%s\\>}" regular)) + (t (format "{\\<%s\\>\\|%s}" regular regexp)))))))) + return-match + t t)))) + (t match)))) (defun org-op-to-function (op &optional stringp) "Turn an operator into the appropriate function." (setq op (cond - ((equal op "<" ) '(< string< org-time<)) + ((equal op "<" ) '(< org-string< org-time<)) ((equal op ">" ) '(> org-string> org-time>)) ((member op '("<=" "=<")) '(<= org-string<= org-time<=)) ((member op '(">=" "=>")) '(>= org-string>= org-time>=)) ((member op '("=" "==")) '(= string= org-time=)) - ((member op '("<>" "!=")) '(org<> org-string<> org-time<>)))) + ((member op '("<>" "!=")) '(/= org-string<> org-time<>)))) (nth (if (eq stringp 'time) 2 (if stringp 1 0)) op)) -(defun org<> (a b) (not (= a b))) -(defun org-string<= (a b) (or (string= a b) (string< a b))) -(defun org-string>= (a b) (not (string< a b))) -(defun org-string> (a b) (and (not (string= a b)) (not (string< a b)))) -(defun org-string<> (a b) (not (string= a b))) -(defun org-time= (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (= a b))) -(defun org-time< (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (< a b))) -(defun org-time<= (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (<= a b))) -(defun org-time> (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (> a b))) -(defun org-time>= (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (>= a b))) -(defun org-time<> (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (org<> a b))) -(defun org-2ft (s) - "Convert S to a floating point time. -If S is already a number, just return it. If it is a string, parse -it as a time string and apply `float-time' to it. If S is nil, just return 0." - (cond - ((numberp s) s) - ((stringp s) - (condition-case nil - (float-time (org-time-string-to-time s)) - (error 0))) - (t 0))) - -(defun org-time-today () - "Time in seconds today at 0:00. -Returns the float number of seconds since the beginning of the -epoch to the beginning of today (00:00)." - (float-time (apply #'encode-time 0 0 0 (nthcdr 3 (decode-time))))) - -(defun org-matcher-time (s) - "Interpret a time comparison value." - (save-match-data - (cond - ((string= s "<now>") (float-time)) - ((string= s "<today>") (org-time-today)) - ((string= s "<tomorrow>") (+ 86400.0 (org-time-today))) - ((string= s "<yesterday>") (- (org-time-today) 86400.0)) - ((string-match "^<\\([-+][0-9]+\\)\\([hdwmy]\\)>$" s) - (+ (org-time-today) - (* (string-to-number (match-string 1 s)) - (cdr (assoc (match-string 2 s) - '(("d" . 86400.0) ("w" . 604800.0) - ("m" . 2678400.0) ("y" . 31557600.0))))))) - (t (org-2ft s))))) - -(defun org-match-any-p (re list) - "Does re match any element of list?" - (setq list (mapcar (lambda (x) (string-match re x)) list)) - (delq nil list)) - (defvar org-add-colon-after-tag-completion nil) ;; dynamically scoped param (defvar org-tags-overlay (make-overlay 1 1)) (delete-overlay org-tags-overlay) -(defun org-get-local-tags-at (&optional pos) - "Get a list of tags defined in the current headline." - (org-get-tags-at pos 'local)) - -(defun org-get-local-tags () - "Get a list of tags defined in the current headline." - (org-get-tags-at nil 'local)) - -(defun org-get-tags-at (&optional pos local) - "Get a list of all headline tags applicable at POS. -POS defaults to point. If tags are inherited, the list contains -the targets in the same sequence as the headlines appear, i.e. -the tags of the current headline come last. -When LOCAL is non-nil, only return tags from the current headline, -ignore inherited ones." - (interactive) - (if (and org-trust-scanner-tags - (or (not pos) (equal pos (point))) - (not local)) - org-scanner-tags - (let (tags ltags lastpos parent) - (save-excursion - (save-restriction - (widen) - (goto-char (or pos (point))) - (save-match-data - (catch 'done - (condition-case nil - (progn - (org-back-to-heading t) - (while (not (equal lastpos (point))) - (setq lastpos (point)) - (when (looking-at ".+?:\\([[:alnum:]_@#%:]+\\):[ \t]*$") - (setq ltags (org-split-string - (match-string-no-properties 1) ":")) - (when parent - (setq ltags (mapcar 'org-add-prop-inherited ltags))) - (setq tags (append - (if parent - (org-remove-uninherited-tags ltags) - ltags) - tags))) - (or org-use-tag-inheritance (throw 'done t)) - (when local (throw 'done t)) - (or (org-up-heading-safe) (error nil)) - (setq parent t))) - (error nil))))) - (if local - tags - (reverse (delete-dups - (reverse (append - (org-remove-uninherited-tags - org-file-tags) - tags))))))))) - (defun org-add-prop-inherited (s) (add-text-properties 0 (length s) '(inherited t) s) s) @@ -14759,14 +12223,9 @@ If ONOFF is `on' or `off', don't toggle but set to this state." (save-excursion (org-back-to-heading t) (let ((current - (when (re-search-forward "[ \t]:\\([[:alnum:]_@#%:]+\\):[ \t]*$" - (line-end-position) t) - (let ((tags (match-string 1))) - ;; Clear current tags. - (replace-match "") - ;; Reverse the tags list so any new tag is appended to - ;; the current list of tags. - (nreverse (org-split-string tags ":"))))) + ;; Reverse the tags list so any new tag is appended to the + ;; current list of tags. + (nreverse (org-get-tags nil t))) res) (pcase onoff (`off (setq current (delete tag current))) @@ -14774,190 +12233,165 @@ If ONOFF is `on' or `off', don't toggle but set to this state." (setq res t) (cl-pushnew tag current :test #'equal)) (_ (setq current (delete tag current)))) - (end-of-line) - (if current - (progn - (insert " :" (mapconcat #'identity (nreverse current) ":") ":") - (org-set-tags nil t)) - (delete-horizontal-space)) - (run-hooks 'org-after-tags-change-hook) + (org-set-tags (nreverse current)) res))) (defun org--align-tags-here (to-col) "Align tags on the current headline to TO-COL. -Assume point is on a headline." - (let ((pos (point))) - (beginning-of-line) - (if (or (not (looking-at ".*?\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")) - (>= pos (match-beginning 2))) - ;; No tags or point within tags: do not align. - (goto-char pos) - (goto-char (match-beginning 1)) - (let ((shift (max (- (if (>= to-col 0) to-col - (- (abs to-col) (string-width (match-string 2)))) - (current-column)) - 1))) - (replace-match (make-string shift ?\s) nil nil nil 1) - ;; Preserve initial position, if possible. In any case, stop - ;; before tags. - (when (< pos (point)) (goto-char pos)))))) - -(defun org-set-tags-command (&optional arg just-align) - "Call the set-tags command for the current entry." +Assume point is on a headline. Preserve point when aligning +tags." + (when (org-match-line org-tag-line-re) + (let* ((tags-start (match-beginning 1)) + (blank-start (save-excursion + (goto-char tags-start) + (skip-chars-backward " \t") + (point))) + (new (max (if (>= to-col 0) to-col + (- (abs to-col) (string-width (match-string 1)))) + ;; Introduce at least one space after the heading + ;; or the stars. + (save-excursion + (goto-char blank-start) + (1+ (current-column))))) + (current + (save-excursion (goto-char tags-start) (current-column))) + (origin (point-marker)) + (column (current-column)) + (in-blank? (and (> origin blank-start) (<= origin tags-start)))) + (when (/= new current) + (delete-region blank-start tags-start) + (goto-char blank-start) + (let ((indent-tabs-mode nil)) (indent-to new)) + ;; Try to move back to original position. If point was in the + ;; blanks before the tags, ORIGIN marker is of no use because + ;; it now points to BLANK-START. Use COLUMN instead. + (if in-blank? (org-move-to-column column) (goto-char origin)))))) + +(defun org-set-tags-command (&optional arg) + "Set the tags for the current visible entry. + +When called with `\\[universal-argument]' prefix argument ARG, \ +realign all tags +in the current buffer. + +When called with `\\[universal-argument] \\[universal-argument]' prefix argument, \ +unconditionally do not +offer the fast tag selection interface. + +If a region is active, set tags in the region according to the +setting of `org-loop-over-headlines-in-active-region'. + +This function is for interactive use only; +in Lisp code use `org-set-tags' instead." (interactive "P") - (if (or (org-at-heading-p) (and arg (org-before-first-heading-p))) - (org-set-tags arg just-align) - (save-excursion - (unless (and (org-region-active-p) - org-loop-over-headlines-in-active-region) - (org-back-to-heading t)) - (org-set-tags arg just-align)))) - -(defun org-set-tags-to (data) - "Set the tags of the current entry to DATA, replacing current tags. -DATA may be a tags string like \":aa:bb:cc:\", or a list of tags. -If DATA is nil or the empty string, all tags are removed." - (interactive "sTags: ") - (let ((data - (pcase (if (stringp data) (org-trim data) data) - ((or `nil "") nil) - ((pred listp) (format ":%s:" (mapconcat #'identity data ":"))) - ((pred stringp) - (format ":%s:" - (mapconcat #'identity (org-split-string data ":+") ":"))) - (_ (error "Invalid tag specification: %S" data))))) - (org-with-wide-buffer - (org-back-to-heading t) - (let ((case-fold-search nil)) (looking-at org-complex-heading-regexp)) - (when (or (match-end 5) data) - (goto-char (or (match-beginning 5) (line-end-position))) - (skip-chars-backward " \t") - (delete-region (point) (line-end-position)) - (when data - (insert " " data) - (org-set-tags nil 'align)))))) + (let ((org-use-fast-tag-selection + (unless (equal '(16) arg) org-use-fast-tag-selection))) + (cond + ((equal '(4) arg) (org-align-tags t)) + ((and (org-region-active-p) org-loop-over-headlines-in-active-region) + (let (org-loop-over-headlines-in-active-region) ; hint: infinite recursion. + (org-map-entries + #'org-set-tags-command + nil + (if (eq org-loop-over-headlines-in-active-region 'start-level) + 'region-start-level + 'region) + (lambda () (when (org-invisible-p) (org-end-of-subtree nil t)))))) + (t + (save-excursion + (org-back-to-heading) + (let* ((all-tags (org-get-tags)) + (table (setq org-last-tags-completion-table + (org--tag-add-to-alist + (and org-complete-tags-always-offer-all-agenda-tags + (org-global-tags-completion-table + (org-agenda-files))) + (or org-current-tag-alist (org-get-buffer-tags))))) + (current-tags + (cl-remove-if (lambda (tag) (get-text-property 0 'inherited tag)) + all-tags)) + (inherited-tags + (cl-remove-if-not (lambda (tag) (get-text-property 0 'inherited tag)) + all-tags)) + (tags + (replace-regexp-in-string + ;; Ignore all forbidden characters in tags. + "[^[:alnum:]_@#%]+" ":" + (if (or (eq t org-use-fast-tag-selection) + (and org-use-fast-tag-selection + (delq nil (mapcar #'cdr table)))) + (org-fast-tag-selection + current-tags + inherited-tags + table + (and org-fast-tag-selection-include-todo org-todo-key-alist)) + (let ((org-add-colon-after-tag-completion (< 1 (length table)))) + (org-trim (completing-read + "Tags: " + #'org-tags-completion-function + nil nil (org-make-tag-string current-tags) + 'org-tags-history))))))) + (org-set-tags tags))))))) + +(defun org-align-tags (&optional all) + "Align tags in current entry. +When optional argument ALL is non-nil, align all tags in the +visible part of the buffer." + (let ((get-indent-column + (lambda () + (let ((offset (if (bound-and-true-p org-indent-mode) + (* (1- org-indent-indentation-per-level) + (1- (org-current-level))) + 0))) + (+ org-tags-column + (if (> org-tags-column 0) (- offset) offset)))))) + (if (and (not all) (org-at-heading-p)) + (org--align-tags-here (funcall get-indent-column)) + (save-excursion + (if all + (progn + (goto-char (point-min)) + (while (re-search-forward org-tag-line-re nil t) + (org--align-tags-here (funcall get-indent-column)))) + (org-back-to-heading t) + (org--align-tags-here (funcall get-indent-column))))))) -(defun org-align-all-tags () - "Align the tags in all headings." - (interactive) - (save-excursion - (or (ignore-errors (org-back-to-heading t)) - (outline-next-heading)) - (if (org-at-heading-p) - (org-set-tags t) - (message "No headings")))) +(defun org-set-tags (tags) + "Set the tags of the current entry to TAGS, replacing current tags. -(defvar org-indent-indentation-per-level) -(defun org-set-tags (&optional arg just-align) - "Set the tags for the current headline. -With prefix ARG, realign all tags in headings in the current buffer. -When JUST-ALIGN is non-nil, only align tags." - (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) - 'region-start-level - 'region)) - org-loop-over-headlines-in-active-region) - (org-map-entries - ;; We don't use ARG and JUST-ALIGN here because these args - ;; are not useful when looping over headlines. - #'org-set-tags - org-loop-over-headlines-in-active-region - cl - '(when (org-invisible-p) (org-end-of-subtree nil t)))) - (let ((org-setting-tags t)) - (if arg - (save-excursion - (goto-char (point-min)) - (while (re-search-forward org-outline-regexp-bol nil t) - (org-set-tags nil t) - (end-of-line)) - (message "All tags realigned to column %d" org-tags-column)) - (let* ((current (org-get-tags-string)) - (tags - (if just-align current - ;; Get a new set of tags from the user. - (save-excursion - (let* ((table - (setq - org-last-tags-completion-table - (org-tag-add-to-alist - (and - org-complete-tags-always-offer-all-agenda-tags - (org-global-tags-completion-table - (org-agenda-files))) - (or org-current-tag-alist - (org-get-buffer-tags))))) - (current-tags (org-split-string current ":")) - (inherited-tags - (nreverse (nthcdr (length current-tags) - (nreverse (org-get-tags-at)))))) - (replace-regexp-in-string - "\\([-+&]+\\|,\\)" - ":" - (if (or (eq t org-use-fast-tag-selection) - (and org-use-fast-tag-selection - (delq nil (mapcar #'cdr table)))) - (org-fast-tag-selection - current-tags inherited-tags table - (and org-fast-tag-selection-include-todo - org-todo-key-alist)) - (let ((org-add-colon-after-tag-completion - (< 1 (length table)))) - (org-trim - (completing-read - "Tags: " - #'org-tags-completion-function - nil nil current 'org-tags-history)))))))))) - - (when org-tags-sort-function - (setq tags - (mapconcat - #'identity - (sort (org-split-string tags "[^[:alnum:]_@#%]+") - org-tags-sort-function) - ":"))) - - (if (or (string= ":" tags) - (string= "::" tags)) - (setq tags "")) - (if (not (org-string-nw-p tags)) (setq tags "") - (unless (string-suffix-p ":" tags) (setq tags (concat tags ":"))) - (unless (string-prefix-p ":" tags) (setq tags (concat ":" tags)))) - - ;; Insert new tags at the correct column. - (unless (equal current tags) - (save-excursion - (beginning-of-line) - (let ((case-fold-search nil)) - (looking-at org-complex-heading-regexp)) - ;; Remove current tags, if any. - (when (match-end 5) (replace-match "" nil nil nil 5)) - ;; Insert new tags, if any. Otherwise, remove trailing - ;; white spaces. - (end-of-line) - (if (not (equal tags "")) - ;; When text is being inserted on an invisible - ;; region boundary, it can be inadvertently sucked - ;; into invisibility. - (outline-flag-region (point) (progn (insert " " tags) (point)) nil) - (skip-chars-backward " \t") - (delete-region (point) (line-end-position))))) - ;; Align tags, if any. Fix tags column if `org-indent-mode' - ;; is on. - (unless (equal tags "") - (let* ((level (save-excursion - (beginning-of-line) - (skip-chars-forward "*"))) - (offset (if (bound-and-true-p org-indent-mode) - (* (1- org-indent-indentation-per-level) - (1- level)) - 0)) - (tags-column - (+ org-tags-column - (if (> org-tags-column 0) (- offset) offset)))) - (org--align-tags-here tags-column)))) - (unless just-align (run-hooks 'org-after-tags-change-hook)))))) +TAGS may be a tags string like \":aa:bb:cc:\", or a list of tags. +If TAGS is nil or the empty string, all tags are removed. + +This function assumes point is on a headline." + (org-with-wide-buffer + (let ((tags (pcase tags + ((pred listp) tags) + ((pred stringp) (split-string (org-trim tags) ":" t)) + (_ (error "Invalid tag specification: %S" tags)))) + (old-tags (org-get-tags nil t)) + (tags-change? nil)) + (when (functionp org-tags-sort-function) + (setq tags (sort tags org-tags-sort-function))) + (setq tags-change? (not (equal tags old-tags))) + (when tags-change? + ;; Delete previous tags and any trailing white space. + (goto-char (if (org-match-line org-tag-line-re) (match-beginning 1) + (line-end-position))) + (skip-chars-backward " \t") + (delete-region (point) (line-end-position)) + ;; Deleting white spaces may break an otherwise empty headline. + ;; Re-introduce one space in this case. + (unless (org-at-heading-p) (insert " ")) + (when tags + (save-excursion (insert " " (org-make-tag-string tags))) + ;; When text is being inserted on an invisible region + ;; boundary, it can be inadvertently sucked into + ;; invisibility. + (unless (org-invisible-p (line-beginning-position)) + (org-flag-region (point) (line-end-position) nil 'outline)))) + ;; Align tags, if any. + (when tags (org-align-tags)) + (when tags-change? (run-hooks 'org-after-tags-change-hook))))) (defun org-change-tag-in-region (beg end tag off) "Add or remove TAG for each entry in the region. @@ -14966,7 +12400,7 @@ This works in the agenda, and also in an Org buffer." (list (region-beginning) (region-end) (let ((org-last-tags-completion-table (if (derived-mode-p 'org-mode) - (org-tag-add-to-alist + (org--tag-add-to-alist (org-get-buffer-tags) (org-global-tags-completion-table)) (org-global-tags-completion-table)))) @@ -15001,32 +12435,33 @@ This works in the agenda, and also in an Org buffer." (message "Tag :%s: %s in %d headings" tag (if off "removed" "set") cnt))) (defun org-tags-completion-function (string _predicate &optional flag) - (let (s1 s2 rtn (ctable org-last-tags-completion-table) - (confirm (lambda (x) (stringp (car x))))) - (if (string-match "^\\(.*[-+:&,|]\\)\\([^-+:&,|]*\\)$" string) - (setq s1 (match-string 1 string) - s2 (match-string 2 string)) - (setq s1 "" s2 string)) - (cond - ((eq flag nil) - ;; try completion - (setq rtn (try-completion s2 ctable confirm)) - (when (stringp rtn) - (setq rtn - (concat s1 s2 (substring rtn (length s2)) - (if (and org-add-colon-after-tag-completion - (assoc rtn ctable)) - ":" "")))) - rtn) - ((eq flag t) - ;; all-completions - (all-completions s2 ctable confirm)) - ((eq flag 'lambda) - ;; exact match? - (assoc s2 ctable))))) + "Complete tag STRING. +FLAG specifies the type of completion operation to perform. This +function is passed as a collection function to `completing-read', +which see." + (let ((completion-ignore-case nil) ;tags are case-sensitive + (confirm (lambda (x) (stringp (car x)))) + (prefix "")) + (when (string-match "^\\(.*[-+:&,|]\\)\\([^-+:&,|]*\\)$" string) + (setq prefix (match-string 1 string)) + (setq string (match-string 2 string))) + (pcase flag + (`t (all-completions string org-last-tags-completion-table confirm)) + (`lambda (assoc string org-last-tags-completion-table)) ;exact match? + (`nil + (pcase (try-completion string org-last-tags-completion-table confirm) + ((and completion (pred stringp)) + (concat prefix + completion + (if (and org-add-colon-after-tag-completion + (assoc completion org-last-tags-completion-table)) + ":" + ""))) + (completion completion))) + (_ nil)))) (defun org-fast-tag-insert (kwd tags face &optional end) - "Insert KDW, and the TAGS, the latter with face FACE. + "Insert KWD, and the TAGS, the latter with face FACE. Also insert END." (insert (format "%-12s" (concat kwd ":")) (org-add-props (mapconcat 'identity tags " ") nil 'face face) @@ -15044,7 +12479,7 @@ Also insert END." (defun org-set-current-tags-overlay (current prefix) "Add an overlay to CURRENT tag with PREFIX." - (let ((s (concat ":" (mapconcat 'identity current ":") ":"))) + (let ((s (org-make-tag-string current))) (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) (org-overlay-display org-tags-overlay (concat prefix s)))) @@ -15058,10 +12493,12 @@ TODO keywords, should these have keys assigned to them. If the keys are nil, a-z are automatically assigned. Returns the new tags string, or nil to not change the current settings." (let* ((fulltable (append table todo-table)) - (maxlen (apply 'max (mapcar - (lambda (x) - (if (stringp (car x)) (string-width (car x)) 0)) - fulltable))) + (maxlen (if (null fulltable) 0 + (apply #'max + (mapcar (lambda (x) + (if (stringp (car x)) (string-width (car x)) + 0)) + fulltable)))) (buf (current-buffer)) (expert (eq org-fast-tag-selection-single-key 'expert)) (buffer-tags nil) @@ -15075,8 +12512,8 @@ Returns the new tags string, or nil to not change the current settings." (done-keywords org-done-keywords) groups ingroup intaggroup) (save-excursion - (beginning-of-line 1) - (if (looking-at ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") + (beginning-of-line) + (if (looking-at org-tag-line-re) (setq ov-start (match-beginning 1) ov-end (match-end 1) ov-prefix "") @@ -15090,191 +12527,222 @@ Returns the new tags string, or nil to not change the current settings." " " (make-string (- org-tags-column (current-column)) ?\ )))))) (move-overlay org-tags-overlay ov-start ov-end) - (save-window-excursion - (if expert - (set-buffer (get-buffer-create " *Org tags*")) - (delete-other-windows) - (set-window-buffer (split-window-vertically) (get-buffer-create " *Org tags*")) - (org-switch-to-buffer-other-window " *Org tags*")) - (erase-buffer) - (setq-local org-done-keywords done-keywords) - (org-fast-tag-insert "Inherited" inherited i-face "\n") - (org-fast-tag-insert "Current" current c-face "\n\n") - (org-fast-tag-show-exit exit-after-next) - (org-set-current-tags-overlay current ov-prefix) - (setq tbl fulltable char ?a cnt 0) - (while (setq e (pop tbl)) - (cond - ((eq (car e) :startgroup) - (push '() groups) (setq ingroup t) - (unless (zerop cnt) - (setq cnt 0) - (insert "\n")) - (insert (if (cdr e) (format "%s: " (cdr e)) "") "{ ")) - ((eq (car e) :endgroup) - (setq ingroup nil cnt 0) - (insert "}" (if (cdr e) (format " (%s) " (cdr e)) "") "\n")) - ((eq (car e) :startgrouptag) - (setq intaggroup t) - (unless (zerop cnt) - (setq cnt 0) - (insert "\n")) - (insert "[ ")) - ((eq (car e) :endgrouptag) - (setq intaggroup nil cnt 0) - (insert "]\n")) - ((equal e '(:newline)) - (unless (zerop cnt) - (setq cnt 0) - (insert "\n") - (setq e (car tbl)) - (while (equal (car tbl) '(:newline)) + (save-excursion + (save-window-excursion + (if expert + (set-buffer (get-buffer-create " *Org tags*")) + (delete-other-windows) + (set-window-buffer (split-window-vertically) (get-buffer-create " *Org tags*")) + (org-switch-to-buffer-other-window " *Org tags*")) + (erase-buffer) + (setq-local org-done-keywords done-keywords) + (org-fast-tag-insert "Inherited" inherited i-face "\n") + (org-fast-tag-insert "Current" current c-face "\n\n") + (org-fast-tag-show-exit exit-after-next) + (org-set-current-tags-overlay current ov-prefix) + (setq tbl fulltable char ?a cnt 0) + (while (setq e (pop tbl)) + (cond + ((eq (car e) :startgroup) + (push '() groups) (setq ingroup t) + (unless (zerop cnt) + (setq cnt 0) + (insert "\n")) + (insert (if (cdr e) (format "%s: " (cdr e)) "") "{ ")) + ((eq (car e) :endgroup) + (setq ingroup nil cnt 0) + (insert "}" (if (cdr e) (format " (%s) " (cdr e)) "") "\n")) + ((eq (car e) :startgrouptag) + (setq intaggroup t) + (unless (zerop cnt) + (setq cnt 0) + (insert "\n")) + (insert "[ ")) + ((eq (car e) :endgrouptag) + (setq intaggroup nil cnt 0) + (insert "]\n")) + ((equal e '(:newline)) + (unless (zerop cnt) + (setq cnt 0) (insert "\n") - (setq tbl (cdr tbl))))) - ((equal e '(:grouptags)) (insert " : ")) - (t - (setq tg (copy-sequence (car e)) c2 nil) - (if (cdr e) - (setq c (cdr e)) - ;; automatically assign a character. - (setq c1 (string-to-char - (downcase (substring - tg (if (= (string-to-char tg) ?@) 1 0))))) - (if (or (rassoc c1 ntable) (rassoc c1 table)) - (while (or (rassoc char ntable) (rassoc char table)) - (setq char (1+ char))) - (setq c2 c1)) - (setq c (or c2 char))) - (when ingroup (push tg (car groups))) - (setq tg (org-add-props tg nil 'face - (cond - ((not (assoc tg table)) - (org-get-todo-face tg)) - ((member tg current) c-face) - ((member tg inherited) i-face)))) - (when (equal (caar tbl) :grouptags) - (org-add-props tg nil 'face 'org-tag-group)) - (when (and (zerop cnt) (not ingroup) (not intaggroup)) (insert " ")) - (insert "[" c "] " tg (make-string - (- fwidth 4 (length tg)) ?\ )) - (push (cons tg c) ntable) - (when (= (cl-incf cnt) ncol) - (insert "\n") - (when (or ingroup intaggroup) (insert " ")) - (setq cnt 0))))) - (setq ntable (nreverse ntable)) - (insert "\n") - (goto-char (point-min)) - (unless expert (org-fit-window-to-buffer)) - (setq rtn - (catch 'exit - (while t - (message "[a-z..]:toggle [SPC]:clear [RET]:accept [TAB]:edit [!] %sgroups%s" - (if (not groups) "no " "") - (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) - (setq c (let ((inhibit-quit t)) (read-char-exclusive))) - (setq org-last-tag-selection-key c) - (cond - ((= c ?\r) (throw 'exit t)) - ((= c ?!) - (setq groups (not groups)) - (goto-char (point-min)) - (while (re-search-forward "[{}]" nil t) (replace-match " "))) - ((= c ?\C-c) - (if (not expert) - (org-fast-tag-show-exit - (setq exit-after-next (not exit-after-next))) - (setq expert nil) - (delete-other-windows) - (set-window-buffer (split-window-vertically) " *Org tags*") - (org-switch-to-buffer-other-window " *Org tags*") - (org-fit-window-to-buffer))) - ((or (= c ?\C-g) - (and (= c ?q) (not (rassoc c ntable)))) - (delete-overlay org-tags-overlay) - (setq quit-flag t)) - ((= c ?\ ) - (setq current nil) - (when exit-after-next (setq exit-after-next 'now))) - ((= c ?\t) - (condition-case nil - (setq tg (completing-read - "Tag: " - (or buffer-tags - (with-current-buffer buf - (setq buffer-tags - (org-get-buffer-tags)))))) - (quit (setq tg ""))) - (when (string-match "\\S-" tg) - (cl-pushnew (list tg) buffer-tags :test #'equal) + (setq e (car tbl)) + (while (equal (car tbl) '(:newline)) + (insert "\n") + (setq tbl (cdr tbl))))) + ((equal e '(:grouptags)) (insert " : ")) + (t + (setq tg (copy-sequence (car e)) c2 nil) + (if (cdr e) + (setq c (cdr e)) + ;; automatically assign a character. + (setq c1 (string-to-char + (downcase (substring + tg (if (= (string-to-char tg) ?@) 1 0))))) + (if (or (rassoc c1 ntable) (rassoc c1 table)) + (while (or (rassoc char ntable) (rassoc char table)) + (setq char (1+ char))) + (setq c2 c1)) + (setq c (or c2 char))) + (when ingroup (push tg (car groups))) + (setq tg (org-add-props tg nil 'face + (cond + ((not (assoc tg table)) + (org-get-todo-face tg)) + ((member tg current) c-face) + ((member tg inherited) i-face)))) + (when (equal (caar tbl) :grouptags) + (org-add-props tg nil 'face 'org-tag-group)) + (when (and (zerop cnt) (not ingroup) (not intaggroup)) (insert " ")) + (insert "[" c "] " tg (make-string + (- fwidth 4 (length tg)) ?\ )) + (push (cons tg c) ntable) + (when (= (cl-incf cnt) ncol) + (unless (memq (caar tbl) '(:endgroup :endgrouptag)) + (insert "\n") + (when (or ingroup intaggroup) (insert " "))) + (setq cnt 0))))) + (setq ntable (nreverse ntable)) + (insert "\n") + (goto-char (point-min)) + (unless expert (org-fit-window-to-buffer)) + (setq rtn + (catch 'exit + (while t + (message "[a-z..]:toggle [SPC]:clear [RET]:accept [TAB]:edit [!] %sgroups%s" + (if (not groups) "no " "") + (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) + (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (setq org-last-tag-selection-key c) + (cond + ((= c ?\r) (throw 'exit t)) + ((= c ?!) + (setq groups (not groups)) + (goto-char (point-min)) + (while (re-search-forward "[{}]" nil t) (replace-match " "))) + ((= c ?\C-c) + (if (not expert) + (org-fast-tag-show-exit + (setq exit-after-next (not exit-after-next))) + (setq expert nil) + (delete-other-windows) + (set-window-buffer (split-window-vertically) " *Org tags*") + (org-switch-to-buffer-other-window " *Org tags*") + (org-fit-window-to-buffer))) + ((or (= c ?\C-g) + (and (= c ?q) (not (rassoc c ntable)))) + (delete-overlay org-tags-overlay) + (setq quit-flag t)) + ((= c ?\ ) + (setq current nil) + (when exit-after-next (setq exit-after-next 'now))) + ((= c ?\t) + (condition-case nil + (setq tg (completing-read + "Tag: " + (or buffer-tags + (with-current-buffer buf + (setq buffer-tags + (org-get-buffer-tags)))))) + (quit (setq tg ""))) + (when (string-match "\\S-" tg) + (cl-pushnew (list tg) buffer-tags :test #'equal) + (if (member tg current) + (setq current (delete tg current)) + (push tg current))) + (when exit-after-next (setq exit-after-next 'now))) + ((setq e (rassoc c todo-table) tg (car e)) + (with-current-buffer buf + (save-excursion (org-todo tg))) + (when exit-after-next (setq exit-after-next 'now))) + ((setq e (rassoc c ntable) tg (car e)) (if (member tg current) (setq current (delete tg current)) - (push tg current))) - (when exit-after-next (setq exit-after-next 'now))) - ((setq e (rassoc c todo-table) tg (car e)) - (with-current-buffer buf - (save-excursion (org-todo tg))) - (when exit-after-next (setq exit-after-next 'now))) - ((setq e (rassoc c ntable) tg (car e)) - (if (member tg current) - (setq current (delete tg current)) - (cl-loop for g in groups do - (when (member tg g) - (dolist (x g) (setq current (delete x current))))) - (push tg current)) - (when exit-after-next (setq exit-after-next 'now)))) - - ;; Create a sorted list - (setq current - (sort current - (lambda (a b) - (assoc b (cdr (memq (assoc a ntable) ntable)))))) - (when (eq exit-after-next 'now) (throw 'exit t)) - (goto-char (point-min)) - (beginning-of-line 2) - (delete-region (point) (point-at-eol)) - (org-fast-tag-insert "Current" current c-face) - (org-set-current-tags-overlay current ov-prefix) - (while (re-search-forward "\\[.\\] \\([[:alnum:]_@#%]+\\)" nil t) - (setq tg (match-string 1)) - (add-text-properties - (match-beginning 1) (match-end 1) - (list 'face - (cond - ((member tg current) c-face) - ((member tg inherited) i-face) - (t (get-text-property (match-beginning 1) 'face)))))) - (goto-char (point-min))))) - (delete-overlay org-tags-overlay) - (if rtn - (mapconcat 'identity current ":") - nil)))) - -(defun org-get-tags-string () - "Get the TAGS string in the current headline." - (unless (org-at-heading-p t) - (user-error "Not on a heading")) - (save-excursion - (beginning-of-line 1) - (if (looking-at ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") - (match-string-no-properties 1) - ""))) - -(defun org-get-tags () - "Get the list of tags specified in the current headline." - (org-split-string (org-get-tags-string) ":")) + (cl-loop for g in groups do + (when (member tg g) + (dolist (x g) (setq current (delete x current))))) + (push tg current)) + (when exit-after-next (setq exit-after-next 'now)))) + + ;; Create a sorted list + (setq current + (sort current + (lambda (a b) + (assoc b (cdr (memq (assoc a ntable) ntable)))))) + (when (eq exit-after-next 'now) (throw 'exit t)) + (goto-char (point-min)) + (beginning-of-line 2) + (delete-region (point) (point-at-eol)) + (org-fast-tag-insert "Current" current c-face) + (org-set-current-tags-overlay current ov-prefix) + (let ((tag-re (concat "\\[.\\] \\(" org-tag-re "\\)"))) + (while (re-search-forward tag-re nil t) + (let ((tag (match-string 1))) + (add-text-properties + (match-beginning 1) (match-end 1) + (list 'face + (cond + ((member tag current) c-face) + ((member tag inherited) i-face) + (t (get-text-property (match-beginning 1) ' + face)))))))) + (goto-char (point-min))))) + (delete-overlay org-tags-overlay) + (if rtn + (mapconcat 'identity current ":") + nil))))) + +(defun org-make-tag-string (tags) + "Return string associated to TAGS. +TAGS is a list of strings." + (if (null tags) "" + (format ":%s:" (mapconcat #'identity tags ":")))) + +(defun org--get-local-tags () + "Return list of tags for the current headline. +Assume point is at the beginning of the headline." + (and (looking-at org-tag-line-re) + (split-string (match-string-no-properties 2) ":" t))) + +(defun org-get-tags (&optional pos local) + "Get the list of tags specified in the current headline. + +When argument POS is non-nil, retrieve tags for headline at POS. + +According to `org-use-tag-inheritance', tags may be inherited +from parent headlines, and from the whole document, through +`org-file-tags'. In this case, the returned list of tags +contains tags in this order: file tags, tags inherited from +parent headlines, local tags. + +However, when optional argument LOCAL is non-nil, only return +tags specified at the headline. + +Inherited tags have the `inherited' text property." + (if (and org-trust-scanner-tags + (or (not pos) (eq pos (point))) + (not local)) + org-scanner-tags + (org-with-point-at (or pos (point)) + (unless (org-before-first-heading-p) + (org-back-to-heading t) + (let ((ltags (org--get-local-tags)) itags) + (if (or local (not org-use-tag-inheritance)) ltags + (while (org-up-heading-safe) + (setq itags (append (mapcar #'org-add-prop-inherited + (org--get-local-tags)) + itags))) + (setq itags (append org-file-tags itags)) + (delete-dups + (append (org-remove-uninherited-tags itags) ltags)))))))) (defun org-get-buffer-tags () "Get a table of all tags used in the buffer, for completion." - (org-with-wide-buffer - (goto-char (point-min)) - (let ((tag-re (concat org-outline-regexp-bol - "\\(?:.*?[ \t]\\)?:\\([[:alnum:]_@#%:]+\\):[ \t]*$")) - tags) - (while (re-search-forward tag-re nil t) - (dolist (tag (org-split-string (match-string-no-properties 1) ":")) - (push tag tags))) - (mapcar #'list (append org-file-tags (org-uniquify tags)))))) + (org-with-point-at 1 + (let (tags) + (while (re-search-forward org-tag-line-re nil t) + (setq tags (nconc (split-string (match-string-no-properties 2) ":") + tags))) + (mapcar #'list (delete-dups (append org-file-tags tags)))))) ;;;; The mapping API @@ -15335,7 +12803,7 @@ the scanner. The following items can be given here: If your function needs to retrieve the tags including inherited tags at the *current* entry, you can use the value of the variable `org-scanner-tags' which will be much faster than getting the value -with `org-get-tags-at'. If your function gets properties with +with `org-get-tags'. If your function gets properties with `org-entry-properties' at the *current* entry, bind `org-trust-scanner-tags' to t around the call to `org-entry-properties' to get the same speedup. Note that if your function moves around to retrieve tags and properties at @@ -15504,61 +12972,44 @@ See `org-property-re' for match data, if applicable." (defun org-inc-effort () "Increment the value of the effort property in the current entry." (interactive) - (org-set-effort nil t)) + (org-set-effort t)) (defvar org-clock-effort) ; Defined in org-clock.el. (defvar org-clock-current-task) ; Defined in org-clock.el. -(defun org-set-effort (&optional value increment) +(defun org-set-effort (&optional increment value) "Set the effort property of the current entry. -With numerical prefix arg, use the nth allowed value, 0 stands for the -10th allowed value. - -When INCREMENT is non-nil, set the property to the next allowed value." +If INCREMENT is non-nil, set the property to the next allowed +value. Otherwise, if optional argument VALUE is provided, use +it. Eventually, prompt for the new value if none of the previous +variables is set." (interactive "P") - (when (equal value 0) (setq value 10)) - (let* ((completion-ignore-case t) - (prop org-effort-property) - (cur (org-entry-get nil prop)) - (allowed (org-property-get-allowed-values nil prop 'table)) - (existing (mapcar 'list (org-property-values prop))) - (heading (nth 4 (org-heading-components))) - rpl - (val (cond - ((stringp value) value) - ((and allowed (integerp value)) - (or (car (nth (1- value) allowed)) - (car (org-last allowed)))) - ((and allowed increment) - (or (cl-caadr (member (list cur) allowed)) - (user-error "Allowed effort values are not set"))) - (allowed - (message "Select 1-9,0, [RET%s]: %s" - (if cur (concat "=" cur) "") - (mapconcat 'car allowed " ")) - (setq rpl (read-char-exclusive)) - (if (equal rpl ?\r) - cur - (setq rpl (- rpl ?0)) - (when (equal rpl 0) (setq rpl 10)) - (if (and (> rpl 0) (<= rpl (length allowed))) - (car (nth (1- rpl) allowed)) - (org-completing-read "Effort: " allowed nil)))) - (t - (org-completing-read - (concat "Effort" (and cur (string-match "\\S-" cur) - (concat " [" cur "]")) - ": ") - existing nil nil "" nil cur))))) - (unless (equal (org-entry-get nil prop) val) - (org-entry-put nil prop val)) - (org-refresh-property - '((effort . identity) - (effort-minutes . org-duration-to-minutes)) - val) - (when (equal heading (bound-and-true-p org-clock-current-task)) - (setq org-clock-effort (get-text-property (point-at-bol) 'effort)) + (let* ((allowed (org-property-get-allowed-values nil org-effort-property t)) + (current (org-entry-get nil org-effort-property)) + (value + (cond + (increment + (unless allowed (user-error "Allowed effort values are not set")) + (or (cl-caadr (member (list current) allowed)) + (user-error "Unknown value %S among allowed values" current))) + (value + (if (stringp value) value + (error "Invalid effort value: %S" value))) + (t + (let ((must-match + (and allowed + (not (get-text-property 0 'org-unrestricted + (caar allowed)))))) + (completing-read "Effort: " allowed nil must-match)))))) + (unless (equal current value) + (org-entry-put nil org-effort-property value)) + (org-refresh-property '((effort . identity) + (effort-minutes . org-duration-to-minutes)) + value) + (when (equal (org-get-heading t t t t) + (bound-and-true-p org-clock-current-task)) + (setq org-clock-effort value) (org-clock-update-mode-line)) - (message "%s is now %s" prop val))) + (message "%s is now %s" org-effort-property value))) (defun org-entry-properties (&optional pom which) "Get all properties of the current entry. @@ -15629,14 +13080,15 @@ strings." props) (when specific (throw 'exit props))) (when (or (not specific) (string= specific "TAGS")) - (let ((value (org-string-nw-p (org-get-tags-string)))) - (when value (push (cons "TAGS" value) props))) + (let ((tags (org-get-tags nil t))) + (when tags + (push (cons "TAGS" (org-make-tag-string tags)) + props))) (when specific (throw 'exit props))) (when (or (not specific) (string= specific "ALLTAGS")) - (let ((value (org-get-tags-at))) - (when value - (push (cons "ALLTAGS" - (format ":%s:" (mapconcat #'identity value ":"))) + (let ((tags (org-get-tags))) + (when tags + (push (cons "ALLTAGS" (org-make-tag-string tags)) props))) (when specific (throw 'exit props))) (when (or (not specific) (string= specific "BLOCKED")) @@ -15987,10 +13439,10 @@ decreases scheduled or deadline date by one day." ((not (member value org-todo-keywords-1)) (user-error "\"%s\" is not a valid TODO state" value))) (org-todo value) - (org-set-tags nil 'align)) + (org-align-tags)) ((equal property "PRIORITY") (org-priority (if (org-string-nw-p value) (string-to-char value) ?\s)) - (org-set-tags nil 'align)) + (org-align-tags)) ((equal property "SCHEDULED") (forward-line) (if (and (looking-at-p org-planning-line-re) @@ -16033,8 +13485,7 @@ decreases scheduled or deadline date by one day." (org-indent-line))))) (run-hook-with-args 'org-property-changed-functions property value))) -(defun org-buffer-property-keys - (&optional specials defaults columns ignore-malformed) +(defun org-buffer-property-keys (&optional specials defaults columns) "Get all property keys in the current buffer. When SPECIALS is non-nil, also list the special properties that @@ -16045,10 +13496,7 @@ special meaning internally: ARCHIVE, CATEGORY, SUMMARY, DESCRIPTION, LOCATION, and LOGGING and others. When COLUMNS in non-nil, also include property names given in -COLUMN formats in the current buffer. - -When IGNORE-MALFORMED is non-nil, malformed drawer repair will not be -automatically performed, such drawers will be silently ignored." +COLUMN formats in the current buffer." (let ((case-fold-search t) (props (append (and specials org-special-properties) @@ -16057,15 +13505,9 @@ automatically performed, such drawers will be silently ignored." (org-with-wide-buffer (goto-char (point-min)) (while (re-search-forward org-property-start-re nil t) - (let ((range (org-get-property-block))) - (catch 'skip - (unless range - (when (and (not ignore-malformed) - (not (org-before-first-heading-p)) - (y-or-n-p (format "Malformed drawer at %d, repair?" - (line-beginning-position)))) - (org-get-property-block nil t)) - (throw 'skip nil)) + (catch :skip + (let ((range (org-get-property-block))) + (unless range (throw :skip nil)) (goto-char (car range)) (let ((begin (car range)) (end (cdr range))) @@ -16083,7 +13525,7 @@ automatically performed, such drawers will be silently ignored." ;; :PROPERTIES: ;; #+END_EXAMPLE ;; - (if (< begin (point)) (throw 'skip nil) (goto-char begin)) + (if (< begin (point)) (throw :skip nil) (goto-char begin)) (while (< (point) end) (let ((p (progn (looking-at org-property-re) (match-string-no-properties 2)))) @@ -16121,7 +13563,9 @@ automatically performed, such drawers will be silently ignored." (delete-dups values)))) (defun org-insert-property-drawer () - "Insert a property drawer into the current entry." + "Insert a property drawer into the current entry. +Do nothing if the drawer already exists. The newly created +drawer is immediately hidden." (org-with-wide-buffer (if (or (not (featurep 'org-inlinetask)) (org-inlinetask-in-task-p)) (org-back-to-heading t) @@ -16136,6 +13580,7 @@ automatically performed, such drawers will be silently ignored." (let ((begin (1+ (point))) (inhibit-read-only t)) (insert "\n:PROPERTIES:\n:END:") + (org-flag-drawer t nil (line-end-position 0) (point)) (when (eobp) (insert "\n")) (org-indent-region begin (point)))))) @@ -16212,23 +13657,33 @@ This is computed according to `org-property-set-functions-alist'." (or (cdr (assoc property org-property-set-functions-alist)) 'org-completing-read)) -(defun org-read-property-value (property) - "Read PROPERTY value from user." +(defun org-read-property-value (property &optional pom) + "Read value for PROPERTY, as a string. +When optional argument POM is non-nil, completion uses additional +information, i.e., allowed or existing values at point or marker +POM." (let* ((completion-ignore-case t) - (allowed (org-property-get-allowed-values nil property 'table)) - (cur (org-entry-get nil property)) - (prompt (concat property " value" - (if (and cur (string-match "\\S-" cur)) - (concat " [" cur "]") "") ": ")) - (set-function (org-set-property-function property)) - (val (if allowed - (funcall set-function prompt allowed nil - (not (get-text-property 0 'org-unrestricted - (caar allowed)))) - (funcall set-function prompt - (mapcar 'list (org-property-values property)) - nil nil "" nil cur)))) - (org-trim val))) + (allowed + (or (org-property-get-allowed-values nil property 'table) + (and pom (org-property-get-allowed-values pom property 'table)))) + (current (org-entry-get nil property)) + (prompt (format "%s value%s: " + property + (if (org-string-nw-p current) + (format " [%s]" current) + ""))) + (set-function (org-set-property-function property))) + (org-trim + (if allowed + (funcall set-function + prompt allowed nil + (not (get-text-property 0 'org-unrestricted (caar allowed)))) + (let ((all (mapcar #'list + (append (org-property-values property) + (and pom + (org-with-point-at pom + (org-property-values property))))))) + (funcall set-function prompt all nil nil "" nil current)))))) (defvar org-last-set-property nil) (defvar org-last-set-property-value nil) @@ -16562,20 +14017,21 @@ non-nil." ((org-at-timestamp-p 'lax) (match-string 0)))) ;; Default time is either the timestamp at point or today. ;; When entering a range, only the range start is considered. - (default-time (and ts (org-time-string-to-time ts))) + (default-time (and ts (org-time-string-to-time ts))) (default-input (and ts (org-get-compact-tod ts))) (repeater (and ts (string-match "\\([.+-]+[0-9]+[hdwmy] ?\\)+" ts) (match-string 0 ts))) org-time-was-given org-end-time-was-given - (time (if (equal arg '(16)) (current-time) - ;; Preserve `this-command' and `last-command'. - (let ((this-command this-command) - (last-command last-command)) - (org-read-date - arg 'totime nil nil default-time default-input - inactive))))) + (time + (if (equal arg '(16)) (current-time) + ;; Preserve `this-command' and `last-command'. + (let ((this-command this-command) + (last-command last-command)) + (org-read-date + arg 'totime nil nil default-time default-input + inactive))))) (cond ((and ts (memq last-command '(org-time-stamp org-time-stamp-inactive)) @@ -16656,78 +14112,6 @@ with the current time without prompting the user." (defvar org-read-date-analyze-futurep nil) (defvar org-read-date-analyze-forced-year nil) (defvar org-read-date-inactive) - -(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 [(meta shift left)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-month 1)))) - (org-defkey map [(meta shift right)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-month 1)))) - (org-defkey map [(meta shift up)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-year 1)))) - (org-defkey map [(meta shift down)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-year 1)))) - (org-defkey map [?\e (shift left)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-month 1)))) - (org-defkey map [?\e (shift right)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-month 1)))) - (org-defkey map [?\e (shift up)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-year 1)))) - (org-defkey map [?\e (shift down)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-year 1)))) - (org-defkey map [(shift up)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-week 1)))) - (org-defkey map [(shift down)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-week 1)))) - (org-defkey map [(shift left)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-day 1)))) - (org-defkey map [(shift right)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-day 1)))) - (org-defkey map "!" - (lambda () (interactive) - (org-eval-in-calendar '(diary-view-entries)) - (message ""))) - (org-defkey map ">" - (lambda () (interactive) - (org-eval-in-calendar '(calendar-scroll-left 1)))) - (org-defkey map "<" - (lambda () (interactive) - (org-eval-in-calendar '(calendar-scroll-right 1)))) - (org-defkey map "\C-v" - (lambda () (interactive) - (org-eval-in-calendar - '(calendar-scroll-left-three-months 1)))) - (org-defkey map "\M-v" - (lambda () (interactive) - (org-eval-in-calendar - '(calendar-scroll-right-three-months 1)))) - map) - "Keymap for minibuffer commands when using `org-read-date'.") - (defvar org-def) (defvar org-defdecode) (defvar org-with-time) @@ -16808,7 +14192,7 @@ user." (when (< (nth 2 org-defdecode) org-extend-today-until) (setf (nth 2 org-defdecode) -1) (setf (nth 1 org-defdecode) 59) - (setq org-def (encode-time org-defdecode)) + (setq org-def (apply #'encode-time org-defdecode)) (setq org-defdecode (decode-time org-def))) (let* ((timestr (format-time-string (if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") @@ -16935,12 +14319,9 @@ user." (defun org-read-date-analyze (ans def defdecode) "Analyze the combined answer of the date prompt." ;; FIXME: cleanup and comment - ;; Pass `current-time' result to `decode-time' (instead of calling - ;; without arguments) so that only `current-time' has to be - ;; overridden in tests. (let ((org-def def) (org-defdecode defdecode) - (nowdecode (decode-time (current-time))) + (nowdecode (decode-time)) delta deltan deltaw deltadef year month day hour minute second wday pm h2 m2 tl wday1 iso-year iso-weekday iso-week iso-date futurep kill-year) @@ -17117,10 +14498,7 @@ user." (deltan (setq futurep nil) (unless deltadef - ;; Pass `current-time' result to `decode-time' (instead of - ;; calling without arguments) so that only `current-time' has - ;; to be overridden in tests. - (let ((now (decode-time (current-time)))) + (let ((now (decode-time))) (setq day (nth 3 now) month (nth 4 now) year (nth 5 now)))) (cond ((member deltaw '("d" "")) (setq day (+ day deltan))) ((equal deltaw "w") (setq day (+ day (* 7 deltan)))) @@ -17285,15 +14663,15 @@ The command returns the inserted time stamp." time (org-fix-decoded-time t1) str (org-add-props (format-time-string - (substring tf 1 -1) (encode-time time)) + (substring tf 1 -1) (apply 'encode-time time)) nil 'mouse-face 'highlight)) (put-text-property beg end 'display str))) (defun org-fix-decoded-time (time) - "Set 0 instead of nil for the time-related elements of time. + "Set 0 instead of nil for the first 6 elements of time. Don't touch the rest." (let ((n 0)) - (mapcar (lambda (x) (if (or (< (setq n (1+ n)) 7) (= n 10)) (or x 0) x)) time))) + (mapcar (lambda (x) (if (< (setq n (1+ n)) 7) (or x 0) x)) time))) (defun org-time-stamp-to-now (timestamp-string &optional seconds) "Difference between TIMESTAMP-STRING and now in days. @@ -17540,7 +14918,7 @@ days in order to avoid rounding problems." (defun org-time-string-to-time (s) "Convert timestamp string S into internal time." - (encode-time (org-parse-time-string s))) + (apply #'encode-time (org-parse-time-string s))) (defun org-time-string-to-seconds (s) "Convert a timestamp string S into a number of seconds." @@ -17761,37 +15139,11 @@ day number." (list (nth 4 d) (nth 3 d) (nth 5 d)))) ((listp d) (list (nth 4 d) (nth 3 d) (nth 5 d))))) -(defun org-parse-time-string (s &optional nodefault) - "Parse the standard Org time string. - -This should be a lot faster than the normal `parse-time-string'. - -If time is not given, defaults to 0:00. However, with optional -NODEFAULT, hour and minute fields will be nil if not given." - (cond ((string-match org-ts-regexp0 s) - (list 0 - (when (or (match-beginning 8) (not nodefault)) - (string-to-number (or (match-string 8 s) "0"))) - (when (or (match-beginning 7) (not nodefault)) - (string-to-number (or (match-string 7 s) "0"))) - (string-to-number (match-string 4 s)) - (string-to-number (match-string 3 s)) - (string-to-number (match-string 2 s)) - nil nil nil)) - ((string-match "^<[^>]+>$" s) - ;; FIXME: `decode-time' needs to be called with ZONE as its - ;; second argument. However, this requires at least Emacs - ;; 25.1. We can do it when we switch to this version as our - ;; minimal requirement. - ;; FIXME: decode-time needs to be called with t as its - ;; third argument, but this requires at least Emacs 27. - (decode-time (org-matcher-time s))) - (t (error "Not a standard Org time string: %s" s)))) - (defun org-timestamp-up (&optional arg) "Increase the date item at the cursor by one. If the cursor is on the year, change the year. If it is on the month, -the day or the time, change that. +the day or the time, change that. If the cursor is on the enclosing +bracket, change the timestamp type. With prefix ARG, change by that many units." (interactive "p") (org-timestamp-change (prefix-numeric-value arg) nil 'updown)) @@ -17799,7 +15151,8 @@ With prefix ARG, change by that many units." (defun org-timestamp-down (&optional arg) "Decrease the date item at the cursor by one. If the cursor is on the year, change the year. If it is on the month, -the day or the time, change that. +the day or the time, change that. If the cursor is on the enclosing +bracket, change the timestamp type. With prefix ARG, change by that many units." (interactive "p") (org-timestamp-change (- (prefix-numeric-value arg)) nil 'updown)) @@ -17919,10 +15272,16 @@ When matching, the match groups are the following: (defvar org-clock-adjust-closest nil) ; defined in org-clock.el (defun org-timestamp-change (n &optional what updown suppress-tmp-delay) "Change the date in the time stamp at point. -The date will be changed by N times WHAT. WHAT can be `day', `month', -`year', `minute', `second'. If WHAT is not given, the cursor position -in the timestamp determines what will be changed. -When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." + +The date is changed by N times WHAT. WHAT can be `day', `month', +`year', `hour', or `minute'. If WHAT is not given, the cursor +position in the timestamp determines what is changed. + +When optional argument UPDOWN is non-nil, minutes are rounded +according to `org-time-stamp-rounding-minutes'. + +When SUPPRESS-TMP-DELAY is non-nil, suppress delays like +\"--2d\"." (let ((origin (point)) (timestamp? (org-at-timestamp-p 'lax)) origin-cat @@ -17989,7 +15348,7 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." (setcar time0 (or (car time0) 0)) (setcar (nthcdr 1 time0) (or (nth 1 time0) 0)) (setcar (nthcdr 2 time0) (or (nth 2 time0) 0)) - (setq time (encode-time time0)))) + (setq time (apply 'encode-time time0)))) ;; Insert the new time-stamp, and ensure point stays in the same ;; category as before (i.e. not after the last position in that ;; category). @@ -18069,7 +15428,7 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." h (string-to-number (match-string 2 s))) (if (org-pos-in-match-range pos 2) (setq h (+ h n)) - (setq n (* dm (with-no-warnings (signum n)))) + (setq n (* dm (with-no-warnings (cl-signum n)))) (unless (= 0 (setq rem (% m dm))) (setq m (+ m (if (> n 0) (- rem) (- dm rem))))) (setq m (+ m n))) @@ -18137,36 +15496,11 @@ If there is already a time stamp at the cursor position, update it." (org-insert-time-stamp (encode-time 0 0 0 (nth 1 cal-date) (car cal-date) (nth 2 cal-date)))))) -(defcustom org-effort-durations - `(("min" . 1) - ("h" . 60) - ("d" . ,(* 60 8)) - ("w" . ,(* 60 8 5)) - ("m" . ,(* 60 8 5 4)) - ("y" . ,(* 60 8 5 40))) - "Conversion factor to minutes for an effort modifier. - -Each entry has the form (MODIFIER . MINUTES). - -In an effort string, a number followed by MODIFIER is multiplied -by the specified number of MINUTES to obtain an effort in -minutes. - -For example, if the value of this variable is ((\"hours\" . 60)), then an -effort string \"2hours\" is equivalent to 120 minutes." - :group 'org-agenda - :version "26.1" - :package-version '(Org . "8.3") - :type '(alist :key-type (string :tag "Modifier") - :value-type (number :tag "Minutes"))) - (defcustom org-image-actual-width t - "Should we use the actual width of images when inlining them? + "When non-nil, use the actual width of images when inlining them. -When set to t, always use the image width. - -When set to a number, use imagemagick (when available) to set -the image's width to this value. +When set to a number, use imagemagick (when available) to set the +image's width to this value. When set to a number in a list, try to get the width from any #+ATTR.* keyword if it matches a width specification like @@ -18178,7 +15512,9 @@ and fall back on that number if none is found. When set to nil, try to get the width from an #+ATTR.* keyword and fall back on the original width if none is found. -This requires Emacs >= 24.1, build with imagemagick support." +When set to any other non-nil value, always use the image width. + +This requires Emacs >= 24.1, built with imagemagick support." :group 'org-appearance :version "24.4" :package-version '(Org . "8.0") @@ -18522,7 +15858,7 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (pall '(:org-archived t :org-comment t)) (inhibit-read-only t) (org-inhibit-startup org-agenda-inhibit-startup) - (rea (concat ":" org-archive-tag ":")) + (rea (org-make-tag-string (list org-archive-tag))) re pos) (setq org-tag-alist-for-agenda nil org-tag-groups-alist-for-agenda nil) @@ -18552,7 +15888,7 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (setq org-todo-keyword-alist-for-agenda (append org-todo-keyword-alist-for-agenda org-todo-key-alist)) (setq org-tag-alist-for-agenda - (org-tag-add-to-alist + (org--tag-add-to-alist org-tag-alist-for-agenda org-current-tag-alist)) ;; Merge current file's tag groups into global @@ -18563,20 +15899,20 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (if old (setcdr old (org-uniquify (append (cdr old) (cdr alist)))) (push alist org-tag-groups-alist-for-agenda))))) - (org-with-silent-modifications - (save-excursion - (remove-text-properties (point-min) (point-max) pall) - (when org-agenda-skip-archived-trees - (goto-char (point-min)) - (while (re-search-forward rea nil t) - (when (org-at-heading-p t) - (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) - (goto-char (point-min)) - (setq re (format "^\\*+ .*\\<%s\\>" org-comment-string)) - (while (re-search-forward re nil t) - (when (save-match-data (org-in-commented-heading-p t)) - (add-text-properties - (match-beginning 0) (org-end-of-subtree t) pc))))) + (with-silent-modifications + (save-excursion + (remove-text-properties (point-min) (point-max) pall) + (when org-agenda-skip-archived-trees + (goto-char (point-min)) + (while (re-search-forward rea nil t) + (when (org-at-heading-p t) + (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) + (goto-char (point-min)) + (setq re (format "^\\*+ .*\\<%s\\>" org-comment-string)) + (while (re-search-forward re nil t) + (when (save-match-data (org-in-commented-heading-p t)) + (add-text-properties + (match-beginning 0) (org-end-of-subtree t) pc))))) (goto-char pos))))) (setq org-todo-keywords-for-agenda (org-uniquify org-todo-keywords-for-agenda)) @@ -18589,11 +15925,11 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (defvar org-cdlatex-mode-map (make-sparse-keymap) "Keymap for the minor `org-cdlatex-mode'.") -(org-defkey org-cdlatex-mode-map "_" 'org-cdlatex-underscore-caret) -(org-defkey org-cdlatex-mode-map "^" 'org-cdlatex-underscore-caret) -(org-defkey org-cdlatex-mode-map "`" 'cdlatex-math-symbol) -(org-defkey org-cdlatex-mode-map "'" 'org-cdlatex-math-modify) -(org-defkey org-cdlatex-mode-map "\C-c{" 'org-cdlatex-environment-indent) +(org-defkey org-cdlatex-mode-map (kbd "_") #'org-cdlatex-underscore-caret) +(org-defkey org-cdlatex-mode-map (kbd "^") #'org-cdlatex-underscore-caret) +(org-defkey org-cdlatex-mode-map (kbd "`") #'cdlatex-math-symbol) +(org-defkey org-cdlatex-mode-map (kbd "'") #'org-cdlatex-math-modify) +(org-defkey org-cdlatex-mode-map (kbd "C-c {") #'org-cdlatex-environment-indent) (defvar org-cdlatex-texmathp-advice-is-done nil "Flag remembering if we have applied the advice to texmathp already.") @@ -18706,7 +16042,7 @@ environment remains unintended." (let ((ind (if (bolp) 0 (save-excursion (org-return-indent) - (prog1 (org-get-indentation) + (prog1 (current-indentation) (when (progn (skip-chars-forward " \t") (eolp)) (delete-region beg (point))))))) (bol (progn (skip-chars-backward " \t") (bolp)))) @@ -18779,7 +16115,7 @@ looks only before point, not after." (org-in-regexp "\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*"))) -(defun org--format-latex-make-overlay (beg end image &optional imagetype) +(defun org--make-preview-overlay (beg end image &optional imagetype) "Build an overlay between BEG and END using IMAGE file. Argument IMAGETYPE is the extension of the displayed image, as a string. It defaults to \"png\"." @@ -18795,88 +16131,91 @@ as a string. It defaults to \"png\"." 'display (list 'image :type imagetype :file image :ascent 'center)))) -(defun org--list-latex-overlays (&optional beg end) - "List all Org LaTeX overlays in current buffer. -Limit to overlays between BEG and END when those are provided." - (cl-remove-if-not - (lambda (o) (eq (overlay-get o 'org-overlay-type) 'org-latex-overlay)) - (overlays-in (or beg (point-min)) (or end (point-max))))) - -(defun org-remove-latex-fragment-image-overlays (&optional beg end) +(defun org-clear-latex-preview (&optional beg end) "Remove all overlays with LaTeX fragment images in current buffer. When optional arguments BEG and END are non-nil, remove all overlays between them instead. Return a non-nil value when some overlays were removed, nil otherwise." - (let ((overlays (org--list-latex-overlays beg end))) + (let ((overlays + (cl-remove-if-not + (lambda (o) (eq (overlay-get o 'org-overlay-type) 'org-latex-overlay)) + (overlays-in (or beg (point-min)) (or end (point-max)))))) (mapc #'delete-overlay overlays) overlays)) -(defun org-toggle-latex-fragment (&optional arg) - "Preview the LaTeX fragment at point, or all locally or globally. - -If the cursor is on a LaTeX fragment, create the image and overlay -it over the source code, if there is none. Remove it otherwise. -If there is no fragment at point, display all fragments in the -current section. +(defun org--latex-preview-region (beg end) + "Preview LaTeX fragments between BEG and END. +BEG and END are buffer positions." + (let ((file (buffer-file-name (buffer-base-buffer)))) + (save-excursion + (org-format-latex + (concat org-preview-latex-image-directory "org-ltximg") + beg end + ;; Emacs cannot overlay images from remote hosts. Create it in + ;; `temporary-file-directory' instead. + (if (or (not file) (file-remote-p file)) + temporary-file-directory + default-directory) + 'overlays nil 'forbuffer org-preview-latex-default-process)))) + +(defun org-latex-preview (&optional arg) + "Toggle preview of the LaTeX fragment at point. + +If the cursor is on a LaTeX fragment, create the image and +overlay it over the source code, if there is none. Remove it +otherwise. If there is no fragment at point, display images for +all fragments in the current section. + +With a `\\[universal-argument]' prefix argument ARG, clear images \ +for all fragments +in the current section. + +With a `\\[universal-argument] \\[universal-argument]' prefix \ +argument ARG, display image for all +fragments in the buffer. -With prefix ARG, preview or clear image for all fragments in the -current subtree or in the whole buffer when used before the first -headline. With a prefix ARG `\\[universal-argument] \ -\\[universal-argument]' preview or clear images -for all fragments in the buffer." +With a `\\[universal-argument] \\[universal-argument] \ +\\[universal-argument]' prefix argument ARG, clear image for all +fragments in the buffer." (interactive "P") - (when (display-graphic-p) - (catch 'exit - (save-excursion - (let (beg end msg) - (cond - ((or (equal arg '(16)) - (and (equal arg '(4)) - (org-with-limited-levels (org-before-first-heading-p)))) - (if (org-remove-latex-fragment-image-overlays) - (progn (message "LaTeX fragments images removed from buffer") - (throw 'exit nil)) - (setq msg "Creating images for buffer..."))) - ((equal arg '(4)) - (org-with-limited-levels (org-back-to-heading t)) - (setq beg (point)) - (setq end (progn (org-end-of-subtree t) (point))) - (if (org-remove-latex-fragment-image-overlays beg end) - (progn - (message "LaTeX fragment images removed from subtree") - (throw 'exit nil)) - (setq msg "Creating images for subtree..."))) - ((let ((datum (org-element-context))) - (when (memq (org-element-type datum) - '(latex-environment latex-fragment)) - (setq beg (org-element-property :begin datum)) - (setq end (org-element-property :end datum)) - (if (org-remove-latex-fragment-image-overlays beg end) - (progn (message "LaTeX fragment image removed") - (throw 'exit nil)) - (setq msg "Creating image..."))))) - (t - (org-with-limited-levels - (setq beg (if (org-at-heading-p) (line-beginning-position) - (outline-previous-heading) - (point))) - (setq end (progn (outline-next-heading) (point))) - (if (org-remove-latex-fragment-image-overlays beg end) - (progn - (message "LaTeX fragment images removed from section") - (throw 'exit nil)) - (setq msg "Creating images for section..."))))) - (let ((file (buffer-file-name (buffer-base-buffer)))) - (org-format-latex - (concat org-preview-latex-image-directory "org-ltximg") - beg end - ;; Emacs cannot overlay images from remote hosts. Create - ;; it in `temporary-file-directory' instead. - (if (or (not file) (file-remote-p file)) - temporary-file-directory - default-directory) - 'overlays msg 'forbuffer org-preview-latex-default-process)) - (message (concat msg "done"))))))) + (cond + ((not (display-graphic-p)) nil) + ;; Clear whole buffer. + ((equal arg '(64)) + (org-clear-latex-preview (point-min) (point-max)) + (message "LaTeX previews removed from buffer")) + ;; Preview whole buffer. + ((equal arg '(16)) + (message "Creating LaTeX previews in buffer...") + (org--latex-preview-region (point-min) (point-max)) + (message "Creating LaTeX previews in buffer... done.")) + ;; Clear current section. + ((equal arg '(4)) + (org-clear-latex-preview + (if (org-before-first-heading-p) (point-min) + (save-excursion + (org-with-limited-levels (org-back-to-heading t) (point)))) + (org-with-limited-levels (org-entry-end-position)))) + ;; Toggle preview on LaTeX code at point. + ((let ((datum (org-element-context))) + (and (memq (org-element-type datum) '(latex-environment latex-fragment)) + (let ((beg (org-element-property :begin datum)) + (end (org-element-property :end datum))) + (if (org-clear-latex-preview beg end) + (message "LaTeX preview removed") + (message "Creating LaTeX preview...") + (org--latex-preview-region beg end) + (message "Creating LaTeX preview... done.")) + t)))) + ;; Preview current section. + (t + (let ((beg (if (org-before-first-heading-p) (point-min) + (save-excursion + (org-with-limited-levels (org-back-to-heading t) (point))))) + (end (org-with-limited-levels (org-entry-end-position)))) + (message "Creating LaTeX previews in section...") + (org--latex-preview-region beg end) + (message "Creating LaTeX previews in section... done."))))) (defun org-format-latex (prefix &optional beg end dir overlays msg forbuffer processing-type) @@ -18977,7 +16316,7 @@ Some of the options can be changed using the variable (when (eq (overlay-get o 'org-overlay-type) 'org-latex-overlay) (delete-overlay o))) - (org--format-latex-make-overlay beg end movefile imagetype) + (org--make-preview-overlay beg end movefile imagetype) (goto-char end)) (delete-region beg end) (insert @@ -19003,7 +16342,7 @@ Some of the options can be changed using the variable (defun org-create-math-formula (latex-frag &optional mathml-file) "Convert LATEX-FRAG to MathML and store it in MATHML-FILE. Use `org-latex-to-mathml-convert-command'. If the conversion is -sucessful, return the portion between \"<math...> </math>\" +successful, return the portion between \"<math...> </math>\" elements otherwise return nil. When MATHML-FILE is specified, write the results in to that file. When invoked as an interactive command, prompt for LATEX-FRAG, with initial value @@ -19123,7 +16462,6 @@ a HTML file." (cdr (assq processing-type org-preview-latex-process-alist))) (programs (plist-get processing-info :programs)) (error-message (or (plist-get processing-info :message) "")) - (use-xcolor (plist-get processing-info :use-xcolor)) (image-input-type (plist-get processing-info :image-input-type)) (image-output-type (plist-get processing-info :image-output-type)) (post-clean (or (plist-get processing-info :post-clean) @@ -19154,36 +16492,23 @@ a HTML file." (resize-mini-windows nil)) ;Fix Emacs flicker when creating image. (dolist (program programs) (org-check-external-command program error-message)) - (if use-xcolor - (progn (if (eq fg 'default) - (setq fg (org-latex-color :foreground)) - (setq fg (org-latex-color-format fg))) - (if (eq bg 'default) - (setq bg (org-latex-color :background)) - (setq bg (org-latex-color-format - (if (string= bg "Transparent") "white" bg)))) - (with-temp-file texfile - (insert latex-header) - (insert "\n\\begin{document}\n" - "\\definecolor{fg}{rgb}{" fg "}\n" - "\\definecolor{bg}{rgb}{" bg "}\n" - "\n\\pagecolor{bg}\n" - "\n{\\color{fg}\n" - string - "\n}\n" - "\n\\end{document}\n"))) - (if (eq fg 'default) - (setq fg (org-dvipng-color :foreground)) - (unless (string= fg "Transparent") - (setq fg (org-dvipng-color-format fg)))) - (if (eq bg 'default) - (setq bg (org-dvipng-color :background)) - (unless (string= bg "Transparent") - (setq bg (org-dvipng-color-format bg)))) - (with-temp-file texfile - (insert latex-header) - (insert "\n\\begin{document}\n" string "\n\\end{document}\n"))) - + (if (eq fg 'default) + (setq fg (org-latex-color :foreground)) + (setq fg (org-latex-color-format fg))) + (if (eq bg 'default) + (setq bg (org-latex-color :background)) + (setq bg (org-latex-color-format + (if (string= bg "Transparent") "white" bg)))) + (with-temp-file texfile + (insert latex-header) + (insert "\n\\begin{document}\n" + "\\definecolor{fg}{rgb}{" fg "}\n" + "\\definecolor{bg}{rgb}{" bg "}\n" + "\n\\pagecolor{bg}\n" + "\n{\\color{fg}\n" + string + "\n}\n" + "\n\\end{document}\n")) (let* ((err-msg (format "Please adjust `%s' part of \ `org-preview-latex-process-alist'." processing-type)) @@ -19193,9 +16518,7 @@ a HTML file." (image-output-file (org-compile-file image-input-file image-converter image-output-type err-msg log-buf - `((?F . ,(shell-quote-argument fg)) - (?B . ,(shell-quote-argument bg)) - (?D . ,(shell-quote-argument (format "%s" dpi))) + `((?D . ,(shell-quote-argument (format "%s" dpi))) (?S . ,(shell-quote-argument (format "%s" (/ dpi 140.0)))))))) (copy-file image-output-file tofile 'replace) (dolist (e post-clean) @@ -19286,7 +16609,6 @@ SNIPPETS-P indicates if this is run to create snippet images for HTML." "Return string to be used as color value for an RGB component." (format "%g" (/ value 65535.0))) - ;; Image display @@ -19329,7 +16651,10 @@ conventions: from `image-file-name-regexp' and it has no contents. 2. Its description consists in a single link of the previous - type. + type. In this case, that link must be a well-formed plain + or angle link, i.e., it must have an explicit \"file\" type. + +Equip each image with the key-map `image-map'. When optional argument INCLUDE-LINKED is non-nil, also links with a text description part will be inlined. This can be nice for @@ -19338,96 +16663,123 @@ exported files will look like. When optional argument REFRESH is non-nil, refresh existing images between BEG and END. This will create new image displays -only if necessary. BEG and END default to the buffer -boundaries." +only if necessary. + +BEG and END define the considered part. They default to the +buffer boundaries with possible narrowing." (interactive "P") (when (display-graphic-p) (unless refresh (org-remove-inline-images) (when (fboundp 'clear-image-cache) (clear-image-cache))) - (org-with-wide-buffer - (goto-char (or beg (point-min))) - (let* ((case-fold-search t) - (file-extension-re (image-file-name-regexp)) - (link-abbrevs (mapcar #'car - (append org-link-abbrev-alist-local - org-link-abbrev-alist))) - ;; Check absolute, relative file names and explicit - ;; "file:" links. Also check link abbreviations since - ;; some might expand to "file" links. - (file-types-re (format "[][]\\[\\(?:file\\|[./~]%s\\)" - (if (not link-abbrevs) "" - (format "\\|\\(?:%s:\\)" - (regexp-opt link-abbrevs)))))) - (while (re-search-forward file-types-re end t) - (let ((link (save-match-data (org-element-context)))) - ;; Check if we're at an inline image, i.e., an image file - ;; link without a description (unless INCLUDE-LINKED is - ;; non-nil). - (when (and (equal "file" (org-element-property :type link)) - (or include-linked - (null (org-element-contents link))) - (string-match-p file-extension-re - (org-element-property :path link))) - (let ((file (expand-file-name - (org-link-unescape - (org-element-property :path link))))) - (when (file-exists-p file) - (let ((width - ;; Apply `org-image-actual-width' specifications. - (cond - ((not (image-type-available-p 'imagemagick)) nil) - ((eq org-image-actual-width t) nil) - ((listp org-image-actual-width) - (or - ;; First try to find a width among - ;; attributes associated to the paragraph - ;; containing link. - (let ((paragraph - (let ((e link)) - (while (and (setq e (org-element-property - :parent e)) - (not (eq (org-element-type e) - 'paragraph)))) - e))) - (when paragraph - (save-excursion - (goto-char (org-element-property :begin paragraph)) - (when - (re-search-forward - "^[ \t]*#\\+attr_.*?: +.*?:width +\\(\\S-+\\)" - (org-element-property - :post-affiliated paragraph) - t) - (string-to-number (match-string 1)))))) - ;; Otherwise, fall-back to provided number. - (car org-image-actual-width))) - ((numberp org-image-actual-width) - org-image-actual-width))) - (old (get-char-property-and-overlay - (org-element-property :begin link) - 'org-image-overlay))) - (if (and (car-safe old) refresh) - (image-refresh (overlay-get (cdr old) 'display)) - (let ((image (create-image file - (and width 'imagemagick) - nil - :width width))) - (when image - (let ((ov (make-overlay - (org-element-property :begin link) - (progn - (goto-char - (org-element-property :end link)) - (skip-chars-backward " \t") - (point))))) - (overlay-put ov 'display image) - (overlay-put ov 'face 'default) - (overlay-put ov 'org-image-overlay t) - (overlay-put - ov 'modification-hooks - (list 'org-display-inline-remove-overlay)) - (push ov org-inline-image-overlays))))))))))))))) + (let ((end (or end (point-max)))) + (org-with-point-at (or beg (point-min)) + (let* ((case-fold-search t) + (file-extension-re (image-file-name-regexp)) + (link-abbrevs (mapcar #'car + (append org-link-abbrev-alist-local + org-link-abbrev-alist))) + ;; Check absolute, relative file names and explicit + ;; "file:" links. Also check link abbreviations since + ;; some might expand to "file" links. + (file-types-re + (format "\\[\\[\\(?:file%s:\\|attachment:\\|[./~]\\)\\|\\]\\[\\(<?file:\\)" + (if (not link-abbrevs) "" + (concat "\\|" (regexp-opt link-abbrevs)))))) + (while (re-search-forward file-types-re end t) + (let* ((link (org-element-lineage + (save-match-data (org-element-context)) + '(link) t)) + (linktype (org-element-property :type link)) + (inner-start (match-beginning 1)) + (path + (cond + ;; No link at point; no inline image. + ((not link) nil) + ;; File link without a description. Also handle + ;; INCLUDE-LINKED here since it should have + ;; precedence over the next case. I.e., if link + ;; contains filenames in both the path and the + ;; description, prioritize the path only when + ;; INCLUDE-LINKED is non-nil. + ((or (not (org-element-property :contents-begin link)) + include-linked) + (and (or (equal "file" linktype) + (equal "attachment" linktype)) + (org-element-property :path link))) + ;; Link with a description. Check if description + ;; is a filename. Even if Org doesn't have syntax + ;; for those -- clickable image -- constructs, fake + ;; them, as in `org-export-insert-image-links'. + ((not inner-start) nil) + (t + (org-with-point-at inner-start + (and (looking-at + (if (char-equal ?< (char-after inner-start)) + org-link-angle-re + org-link-plain-re)) + ;; File name must fill the whole + ;; description. + (= (org-element-property :contents-end link) + (match-end 0)) + (match-string 2))))))) + (when (and path (string-match-p file-extension-re path)) + (let ((file (if (equal "attachment" linktype) + (progn + (require 'org-attach) + (ignore-errors (org-attach-expand path))) + (expand-file-name path)))) + (when (and file (file-exists-p file)) + (let ((width + ;; Apply `org-image-actual-width' specifications. + (cond + ((eq org-image-actual-width t) nil) + ((listp org-image-actual-width) + (or + ;; First try to find a width among + ;; attributes associated to the paragraph + ;; containing link. + (pcase (org-element-lineage link '(paragraph)) + (`nil nil) + (p + (let* ((case-fold-search t) + (end (org-element-property :post-affiliated p)) + (re "^[ \t]*#\\+attr_.*?: +.*?:width +\\(\\S-+\\)")) + (when (org-with-point-at + (org-element-property :begin p) + (re-search-forward re end t)) + (string-to-number (match-string 1)))))) + ;; Otherwise, fall-back to provided number. + (car org-image-actual-width))) + ((numberp org-image-actual-width) + org-image-actual-width) + (t nil))) + (old (get-char-property-and-overlay + (org-element-property :begin link) + 'org-image-overlay))) + (if (and (car-safe old) refresh) + (image-refresh (overlay-get (cdr old) 'display)) + (let ((image (create-image file + (and (image-type-available-p 'imagemagick) + width 'imagemagick) + nil + :width width))) + (when image + (let ((ov (make-overlay + (org-element-property :begin link) + (progn + (goto-char + (org-element-property :end link)) + (skip-chars-backward " \t") + (point))))) + (overlay-put ov 'display image) + (overlay-put ov 'face 'default) + (overlay-put ov 'org-image-overlay t) + (overlay-put + ov 'modification-hooks + (list 'org-display-inline-remove-overlay)) + (overlay-put ov 'keymap image-map) + (push ov org-inline-image-overlays)))))))))))))))) (defun org-display-inline-remove-overlay (ov after _beg _end &optional _len) "Remove inline-display overlay if a corresponding region is modified." @@ -19442,428 +16794,9 @@ boundaries." (mapc #'delete-overlay org-inline-image-overlays) (setq org-inline-image-overlays nil)) -;;;; Key bindings - -(defun org-remap (map &rest commands) - "In MAP, remap the functions given in COMMANDS. -COMMANDS is a list of alternating OLDDEF NEWDEF command names." - (let (new old) - (while commands - (setq old (pop commands) new (pop commands)) - (org-defkey map (vector 'remap old) new)))) - -;; Outline functions from `outline-mode-prefix-map' -;; that can be remapped in Org: -(define-key org-mode-map [remap outline-mark-subtree] 'org-mark-subtree) -(define-key org-mode-map [remap outline-show-subtree] 'org-show-subtree) -(define-key org-mode-map [remap outline-forward-same-level] - 'org-forward-heading-same-level) -(define-key org-mode-map [remap outline-backward-same-level] - 'org-backward-heading-same-level) -(define-key org-mode-map [remap outline-show-branches] - 'org-kill-note-or-show-branches) -(define-key org-mode-map [remap outline-promote] 'org-promote-subtree) -(define-key org-mode-map [remap outline-demote] 'org-demote-subtree) -(define-key org-mode-map [remap outline-insert-heading] 'org-ctrl-c-ret) -(define-key org-mode-map [remap outline-next-visible-heading] - 'org-next-visible-heading) -(define-key org-mode-map [remap outline-previous-visible-heading] - 'org-previous-visible-heading) -(define-key org-mode-map [remap show-children] 'org-show-children) - -;; Outline functions from `outline-mode-prefix-map' that can not -;; be remapped in Org: - -;; - the column "key binding" shows whether the Outline function is still -;; available in Org mode on the same key that it has been bound to in -;; Outline mode: -;; - "overridden": key used for a different functionality in Org mode -;; - else: key still bound to the same Outline function in Org mode - -;; | Outline function | key binding | Org replacement | -;; |------------------------------------+-------------+--------------------------| -;; | `outline-up-heading' | `C-c C-u' | still same function | -;; | `outline-move-subtree-up' | overridden | better: org-shiftup | -;; | `outline-move-subtree-down' | overridden | better: org-shiftdown | -;; | `show-entry' | overridden | no replacement | -;; | `show-branches' | `C-c C-k' | still same function | -;; | `show-subtree' | overridden | visibility cycling | -;; | `show-all' | overridden | no replacement | -;; | `hide-subtree' | overridden | visibility cycling | -;; | `hide-body' | overridden | no replacement | -;; | `hide-entry' | overridden | visibility cycling | -;; | `hide-leaves' | overridden | no replacement | -;; | `hide-sublevels' | overridden | no replacement | -;; | `hide-other' | overridden | no replacement | - -;; Make `C-c C-x' a prefix key -(org-defkey org-mode-map "\C-c\C-x" (make-sparse-keymap)) - -;; TAB key with modifiers -(org-defkey org-mode-map "\C-i" 'org-cycle) -(org-defkey org-mode-map [(tab)] 'org-cycle) -(org-defkey org-mode-map [(control tab)] 'org-force-cycle-archived) -(org-defkey org-mode-map "\M-\t" nil) ;; Override text-mode binding - -;; The following line is necessary under Suse GNU/Linux -(org-defkey org-mode-map [S-iso-lefttab] 'org-shifttab) -(org-defkey org-mode-map [(shift tab)] 'org-shifttab) -(define-key org-mode-map [backtab] 'org-shifttab) - -(org-defkey org-mode-map [(shift return)] 'org-table-copy-down) -(org-defkey org-mode-map [(meta shift return)] 'org-insert-todo-heading) -(org-defkey org-mode-map (kbd "M-RET") #'org-meta-return) - -;; Cursor keys with modifiers -(org-defkey org-mode-map [(meta left)] 'org-metaleft) -(org-defkey org-mode-map [(meta right)] 'org-metaright) -(org-defkey org-mode-map [(meta up)] 'org-metaup) -(org-defkey org-mode-map [(meta down)] 'org-metadown) - -(org-defkey org-mode-map [(control meta shift right)] 'org-increase-number-at-point) -(org-defkey org-mode-map [(control meta shift left)] 'org-decrease-number-at-point) -(org-defkey org-mode-map [(meta shift left)] 'org-shiftmetaleft) -(org-defkey org-mode-map [(meta shift right)] 'org-shiftmetaright) -(org-defkey org-mode-map [(meta shift up)] 'org-shiftmetaup) -(org-defkey org-mode-map [(meta shift down)] 'org-shiftmetadown) - -(org-defkey org-mode-map [(shift up)] 'org-shiftup) -(org-defkey org-mode-map [(shift down)] 'org-shiftdown) -(org-defkey org-mode-map [(shift left)] 'org-shiftleft) -(org-defkey org-mode-map [(shift right)] 'org-shiftright) - -(org-defkey org-mode-map [(control shift right)] 'org-shiftcontrolright) -(org-defkey org-mode-map [(control shift left)] 'org-shiftcontrolleft) -(org-defkey org-mode-map [(control shift up)] 'org-shiftcontrolup) -(org-defkey org-mode-map [(control shift down)] 'org-shiftcontroldown) - -;; Babel keys -(define-key org-mode-map org-babel-key-prefix org-babel-map) -(dolist (pair org-babel-key-bindings) - (define-key org-babel-map (car pair) (cdr pair))) - -;;; Extra keys for tty access. -;; We only set them when really needed because otherwise the -;; menus don't show the simple keys - -(when (or org-use-extra-keys (not window-system)) - (org-defkey org-mode-map "\C-c\C-xc" 'org-table-copy-down) - (org-defkey org-mode-map "\C-c\C-xM" 'org-insert-todo-heading) - (org-defkey org-mode-map "\C-c\C-xm" 'org-meta-return) - (org-defkey org-mode-map [?\e (return)] 'org-meta-return) - (org-defkey org-mode-map [?\e (left)] 'org-metaleft) - (org-defkey org-mode-map "\C-c\C-xl" 'org-metaleft) - (org-defkey org-mode-map [?\e (right)] 'org-metaright) - (org-defkey org-mode-map "\C-c\C-xr" 'org-metaright) - (org-defkey org-mode-map [?\e (up)] 'org-metaup) - (org-defkey org-mode-map "\C-c\C-xu" 'org-metaup) - (org-defkey org-mode-map [?\e (down)] 'org-metadown) - (org-defkey org-mode-map "\C-c\C-xd" 'org-metadown) - (org-defkey org-mode-map "\C-c\C-xL" 'org-shiftmetaleft) - (org-defkey org-mode-map "\C-c\C-xR" 'org-shiftmetaright) - (org-defkey org-mode-map "\C-c\C-xU" 'org-shiftmetaup) - (org-defkey org-mode-map "\C-c\C-xD" 'org-shiftmetadown) - (org-defkey org-mode-map [?\C-c (up)] 'org-shiftup) - (org-defkey org-mode-map [?\C-c (down)] 'org-shiftdown) - (org-defkey org-mode-map [?\C-c (left)] 'org-shiftleft) - (org-defkey org-mode-map [?\C-c (right)] 'org-shiftright) - (org-defkey org-mode-map [?\C-c ?\C-x (right)] 'org-shiftcontrolright) - (org-defkey org-mode-map [?\C-c ?\C-x (left)] 'org-shiftcontrolleft) - (org-defkey org-mode-map [?\e (tab)] nil) ;; Override text-mode binding - (org-defkey org-mode-map [?\e (shift return)] 'org-insert-todo-heading) - (org-defkey org-mode-map [?\e (shift left)] 'org-shiftmetaleft) - (org-defkey org-mode-map [?\e (shift right)] 'org-shiftmetaright) - (org-defkey org-mode-map [?\e (shift up)] 'org-shiftmetaup) - (org-defkey org-mode-map [?\e (shift down)] 'org-shiftmetadown)) - -;; All the other keys -(org-remap org-mode-map - 'self-insert-command 'org-self-insert-command - 'delete-char 'org-delete-char - 'delete-backward-char 'org-delete-backward-char) -(org-defkey org-mode-map "|" 'org-force-self-insert) - -(org-defkey org-mode-map "\C-c\C-a" 'outline-show-all) ; in case allout messed up. -(org-defkey org-mode-map "\C-c\C-r" 'org-reveal) -(if (boundp 'narrow-map) - (org-defkey narrow-map "s" 'org-narrow-to-subtree) - (org-defkey org-mode-map "\C-xns" 'org-narrow-to-subtree)) -(if (boundp 'narrow-map) - (org-defkey narrow-map "b" 'org-narrow-to-block) - (org-defkey org-mode-map "\C-xnb" 'org-narrow-to-block)) -(if (boundp 'narrow-map) - (org-defkey narrow-map "e" 'org-narrow-to-element) - (org-defkey org-mode-map "\C-xne" 'org-narrow-to-element)) -(org-defkey org-mode-map "\C-\M-t" 'org-transpose-element) -(org-defkey org-mode-map "\M-}" 'org-forward-element) -(org-defkey org-mode-map "\M-{" 'org-backward-element) -(org-defkey org-mode-map "\C-c\C-^" 'org-up-element) -(org-defkey org-mode-map "\C-c\C-_" 'org-down-element) -(org-defkey org-mode-map "\C-c\C-f" 'org-forward-heading-same-level) -(org-defkey org-mode-map "\C-c\C-b" 'org-backward-heading-same-level) -(org-defkey org-mode-map "\C-c\M-f" 'org-next-block) -(org-defkey org-mode-map "\C-c\M-b" 'org-previous-block) -(org-defkey org-mode-map "\C-c$" 'org-archive-subtree) -(org-defkey org-mode-map "\C-c\C-x\C-s" 'org-archive-subtree) -(org-defkey org-mode-map "\C-c\C-x\C-a" 'org-archive-subtree-default) -(org-defkey org-mode-map "\C-c\C-xd" 'org-insert-drawer) -(org-defkey org-mode-map "\C-c\C-xa" 'org-toggle-archive-tag) -(org-defkey org-mode-map "\C-c\C-xA" 'org-archive-to-archive-sibling) -(org-defkey org-mode-map "\C-c\C-xb" 'org-tree-to-indirect-buffer) -(org-defkey org-mode-map "\C-c\C-xq" 'org-toggle-tags-groups) -(org-defkey org-mode-map "\C-c\C-j" 'org-goto) -(org-defkey org-mode-map "\C-c\C-t" 'org-todo) -(org-defkey org-mode-map "\C-c\C-q" 'org-set-tags-command) -(org-defkey org-mode-map "\C-c\C-s" 'org-schedule) -(org-defkey org-mode-map "\C-c\C-d" 'org-deadline) -(org-defkey org-mode-map "\C-c;" 'org-toggle-comment) -(org-defkey org-mode-map "\C-c\C-w" 'org-refile) -(org-defkey org-mode-map "\C-c\M-w" 'org-copy) -(org-defkey org-mode-map "\C-c/" 'org-sparse-tree) ; Minor-mode reserved -(org-defkey org-mode-map "\C-c\\" 'org-match-sparse-tree) ; Minor-mode res. -(org-defkey org-mode-map "\C-c\C-m" 'org-ctrl-c-ret) -(org-defkey org-mode-map "\C-c\C-xc" 'org-clone-subtree-with-time-shift) -(org-defkey org-mode-map "\C-c\C-xv" 'org-copy-visible) -(org-defkey org-mode-map [(control return)] 'org-insert-heading-respect-content) -(org-defkey org-mode-map [(shift control return)] 'org-insert-todo-heading-respect-content) -(org-defkey org-mode-map "\C-c\C-x\C-n" 'org-next-link) -(org-defkey org-mode-map "\C-c\C-x\C-p" 'org-previous-link) -(org-defkey org-mode-map "\C-c\C-l" 'org-insert-link) -(org-defkey org-mode-map "\C-c\M-l" 'org-insert-last-stored-link) -(org-defkey org-mode-map "\C-c\C-\M-l" 'org-insert-all-links) -(org-defkey org-mode-map "\C-c\C-o" 'org-open-at-point) -(org-defkey org-mode-map "\C-c%" 'org-mark-ring-push) -(org-defkey org-mode-map "\C-c&" 'org-mark-ring-goto) -(org-defkey org-mode-map "\C-c\C-z" 'org-add-note) ; Alternative binding -(org-defkey org-mode-map "\C-c." 'org-time-stamp) ; Minor-mode reserved -(org-defkey org-mode-map "\C-c!" 'org-time-stamp-inactive) ; Minor-mode r. -(org-defkey org-mode-map "\C-c," 'org-priority) ; Minor-mode reserved -(org-defkey org-mode-map "\C-c\C-y" 'org-evaluate-time-range) -(org-defkey org-mode-map "\C-c>" 'org-goto-calendar) -(org-defkey org-mode-map "\C-c<" 'org-date-from-calendar) -(org-defkey org-mode-map [(control ?,)] 'org-cycle-agenda-files) -(org-defkey org-mode-map [(control ?\')] 'org-cycle-agenda-files) -(org-defkey org-mode-map "\C-c[" 'org-agenda-file-to-front) -(org-defkey org-mode-map "\C-c]" 'org-remove-file) -(org-defkey org-mode-map "\C-c\C-x<" 'org-agenda-set-restriction-lock) -(org-defkey org-mode-map "\C-c\C-x>" 'org-agenda-remove-restriction-lock) -(org-defkey org-mode-map "\C-c-" 'org-ctrl-c-minus) -(org-defkey org-mode-map "\C-c*" 'org-ctrl-c-star) -(org-defkey org-mode-map "\C-c^" 'org-sort) -(org-defkey org-mode-map "\C-c\C-c" 'org-ctrl-c-ctrl-c) -(org-defkey org-mode-map "\C-c\C-k" 'org-kill-note-or-show-branches) -(org-defkey org-mode-map "\C-c#" 'org-update-statistics-cookies) -(org-defkey org-mode-map [remap open-line] 'org-open-line) -(org-defkey org-mode-map [remap comment-dwim] 'org-comment-dwim) -(org-defkey org-mode-map [remap forward-paragraph] 'org-forward-paragraph) -(org-defkey org-mode-map [remap backward-paragraph] 'org-backward-paragraph) -(org-defkey org-mode-map "\M-^" 'org-delete-indentation) -(org-defkey org-mode-map "\C-m" 'org-return) -(org-defkey org-mode-map "\C-j" 'org-return-indent) -(org-defkey org-mode-map "\C-c?" 'org-table-field-info) -(org-defkey org-mode-map "\C-c " 'org-table-blank-field) -(org-defkey org-mode-map "\C-c+" 'org-table-sum) -(org-defkey org-mode-map "\C-c=" 'org-table-eval-formula) -(org-defkey org-mode-map "\C-c'" 'org-edit-special) -(org-defkey org-mode-map "\C-c`" 'org-table-edit-field) -(org-defkey org-mode-map "\C-c\"a" 'orgtbl-ascii-plot) -(org-defkey org-mode-map "\C-c\"g" 'org-plot/gnuplot) -(org-defkey org-mode-map "\C-c|" 'org-table-create-or-convert-from-region) -(org-defkey org-mode-map [(control ?#)] 'org-table-rotate-recalc-marks) -(org-defkey org-mode-map "\C-c~" 'org-table-create-with-table.el) -(org-defkey org-mode-map "\C-c\C-a" 'org-attach) -(org-defkey org-mode-map "\C-c}" 'org-table-toggle-coordinate-overlays) -(org-defkey org-mode-map "\C-c{" 'org-table-toggle-formula-debugger) -(org-defkey org-mode-map "\C-c\C-e" 'org-export-dispatch) -(org-defkey org-mode-map "\C-c:" 'org-toggle-fixed-width) -(org-defkey org-mode-map "\C-c\C-x\C-f" 'org-emphasize) -(org-defkey org-mode-map "\C-c\C-xf" 'org-footnote-action) -(org-defkey org-mode-map "\C-c\C-x\C-mg" 'org-mobile-pull) -(org-defkey org-mode-map "\C-c\C-x\C-mp" 'org-mobile-push) -(org-defkey org-mode-map "\C-c@" 'org-mark-subtree) -(org-defkey org-mode-map "\M-h" 'org-mark-element) -(org-defkey org-mode-map [?\C-c (control ?*)] 'org-list-make-subtree) -;;(org-defkey org-mode-map [?\C-c (control ?-)] 'org-list-make-list-from-subtree) - -(org-defkey org-mode-map "\C-c\C-x\C-w" 'org-cut-special) -(org-defkey org-mode-map "\C-c\C-x\M-w" 'org-copy-special) -(org-defkey org-mode-map "\C-c\C-x\C-y" 'org-paste-special) - -(org-defkey org-mode-map "\C-c\C-x\C-t" 'org-toggle-time-stamp-overlays) -(org-defkey org-mode-map "\C-c\C-x\C-i" 'org-clock-in) -(org-defkey org-mode-map "\C-c\C-x\C-x" 'org-clock-in-last) -(org-defkey org-mode-map "\C-c\C-x\C-z" 'org-resolve-clocks) -(org-defkey org-mode-map "\C-c\C-x\C-o" 'org-clock-out) -(org-defkey org-mode-map "\C-c\C-x\C-j" 'org-clock-goto) -(org-defkey org-mode-map "\C-c\C-x\C-q" 'org-clock-cancel) -(org-defkey org-mode-map "\C-c\C-x\C-d" 'org-clock-display) -(org-defkey org-mode-map "\C-c\C-x\C-r" 'org-clock-report) -(org-defkey org-mode-map "\C-c\C-x\C-u" 'org-dblock-update) -(org-defkey org-mode-map "\C-c\C-x\C-l" 'org-toggle-latex-fragment) -(org-defkey org-mode-map "\C-c\C-x\C-v" 'org-toggle-inline-images) -(org-defkey org-mode-map "\C-c\C-x\C-\M-v" 'org-redisplay-inline-images) -(org-defkey org-mode-map "\C-c\C-x\\" 'org-toggle-pretty-entities) -(org-defkey org-mode-map "\C-c\C-x\C-b" 'org-toggle-checkbox) -(org-defkey org-mode-map "\C-c\C-xp" 'org-set-property) -(org-defkey org-mode-map "\C-c\C-xP" 'org-set-property-and-value) -(org-defkey org-mode-map "\C-c\C-xe" 'org-set-effort) -(org-defkey org-mode-map "\C-c\C-xE" 'org-inc-effort) -(org-defkey org-mode-map "\C-c\C-xo" 'org-toggle-ordered-property) -(org-defkey org-mode-map "\C-c\C-xi" 'org-columns-insert-dblock) -(org-defkey org-mode-map [(control ?c) (control ?x) ?\;] 'org-timer-set-timer) - -(org-defkey org-mode-map "\C-c\C-x." 'org-timer) -(org-defkey org-mode-map "\C-c\C-x-" 'org-timer-item) -(org-defkey org-mode-map "\C-c\C-x0" 'org-timer-start) -(org-defkey org-mode-map "\C-c\C-x_" 'org-timer-stop) -(org-defkey org-mode-map "\C-c\C-x," 'org-timer-pause-or-continue) - -(define-key org-mode-map "\C-c\C-x\C-c" 'org-columns) - -(define-key org-mode-map "\C-c\C-x!" 'org-reload) - -(define-key org-mode-map "\C-c\C-xg" 'org-feed-update-all) -(define-key org-mode-map "\C-c\C-xG" 'org-feed-goto-inbox) - -(define-key org-mode-map "\C-c\C-x[" 'org-reftex-citation) - - -(defconst org-speed-commands-default - '( - ("Outline Navigation") - ("n" . (org-speed-move-safe 'org-next-visible-heading)) - ("p" . (org-speed-move-safe 'org-previous-visible-heading)) - ("f" . (org-speed-move-safe 'org-forward-heading-same-level)) - ("b" . (org-speed-move-safe 'org-backward-heading-same-level)) - ("F" . org-next-block) - ("B" . org-previous-block) - ("u" . (org-speed-move-safe 'outline-up-heading)) - ("j" . org-goto) - ("g" . (org-refile t)) - ("Outline Visibility") - ("c" . org-cycle) - ("C" . org-shifttab) - (" " . org-display-outline-path) - ("s" . org-narrow-to-subtree) - ("=" . org-columns) - ("Outline Structure Editing") - ("U" . org-metaup) - ("D" . org-metadown) - ("r" . org-metaright) - ("l" . org-metaleft) - ("R" . org-shiftmetaright) - ("L" . org-shiftmetaleft) - ("i" . (progn (forward-char 1) (call-interactively - 'org-insert-heading-respect-content))) - ("^" . org-sort) - ("w" . org-refile) - ("a" . org-archive-subtree-default-with-confirmation) - ("@" . org-mark-subtree) - ("#" . org-toggle-comment) - ("Clock Commands") - ("I" . org-clock-in) - ("O" . org-clock-out) - ("Meta Data Editing") - ("t" . org-todo) - ("," . (org-priority)) - ("0" . (org-priority ?\ )) - ("1" . (org-priority ?A)) - ("2" . (org-priority ?B)) - ("3" . (org-priority ?C)) - (":" . org-set-tags-command) - ("e" . org-set-effort) - ("E" . org-inc-effort) - ("W" . (lambda(m) (interactive "sMinutes before warning: ") - (org-entry-put (point) "APPT_WARNTIME" m))) - ("Agenda Views etc") - ("v" . org-agenda) - ("/" . org-sparse-tree) - ("Misc") - ("o" . org-open-at-point) - ("?" . org-speed-command-help) - ("<" . (org-agenda-set-restriction-lock 'subtree)) - (">" . (org-agenda-remove-restriction-lock)) - ) - "The default speed commands.") - -(defun org-print-speed-command (e) - (if (> (length (car e)) 1) - (progn - (princ "\n") - (princ (car e)) - (princ "\n") - (princ (make-string (length (car e)) ?-)) - (princ "\n")) - (princ (car e)) - (princ " ") - (if (symbolp (cdr e)) - (princ (symbol-name (cdr e))) - (prin1 (cdr e))) - (princ "\n"))) - -(defun org-speed-command-help () - "Show the available speed commands." - (interactive) - (if (not org-use-speed-commands) - (user-error "Speed commands are not activated, customize `org-use-speed-commands'") - (with-output-to-temp-buffer "*Help*" - (princ "User-defined Speed commands\n===========================\n") - (mapc #'org-print-speed-command org-speed-commands-user) - (princ "\n") - (princ "Built-in Speed commands\n=======================\n") - (mapc #'org-print-speed-command org-speed-commands-default)) - (with-current-buffer "*Help*" - (setq truncate-lines t)))) - -(defun org-speed-move-safe (cmd) - "Execute CMD, but make sure that the cursor always ends up in a headline. -If not, return to the original position and throw an error." - (interactive) - (let ((pos (point))) - (call-interactively cmd) - (unless (and (bolp) (org-at-heading-p)) - (goto-char pos) - (error "Boundary reached while executing %s" cmd)))) - (defvar org-self-insert-command-undo-counter 0) - -(defvar org-table-auto-blank-field) ; defined in org-table.el (defvar org-speed-command nil) -(defun org-speed-command-activate (keys) - "Hook for activating single-letter speed commands. -`org-speed-commands-default' specifies a minimal command set. -Use `org-speed-commands-user' for further customization." - (when (or (and (bolp) (looking-at org-outline-regexp)) - (and (functionp org-use-speed-commands) - (funcall org-use-speed-commands))) - (cdr (assoc keys (append org-speed-commands-user - org-speed-commands-default))))) - -(defun org-babel-speed-command-activate (keys) - "Hook for activating single-letter code block commands." - (when (and (bolp) (looking-at org-babel-src-block-regexp)) - (cdr (assoc keys org-babel-key-bindings)))) - -(defcustom org-speed-command-hook - '(org-speed-command-activate org-babel-speed-command-activate) - "Hook for activating speed commands at strategic locations. -Hook functions are called in sequence until a valid handler is -found. - -Each hook takes a single argument, a user-pressed command key -which is also a `self-insert-command' from the global map. - -Within the hook, examine the cursor position and the command key -and return nil or a valid handler as appropriate. Handler could -be one of an interactive command, a function, or a form. - -Set `org-use-speed-commands' to non-nil value to enable this -hook. The default setting is `org-speed-command-activate'." - :group 'org-structure - :version "24.1" - :type 'hook) - (defun org-self-insert-command (N) "Like `self-insert-command', use overwrite-mode for whitespace in tables. If the cursor is in a table looking at whitespace, the whitespace is @@ -19888,12 +16821,13 @@ overwritten, and the table is not marked as requiring realignment." (t (let (org-use-speed-commands) (call-interactively 'org-self-insert-command))))) ((and - (org-at-table-p) - (eq N 1) + (= N 1) (not (org-region-active-p)) + (org-at-table-p) (progn ;; Check if we blank the field, and if that triggers align. - (and (featurep 'org-table) org-table-auto-blank-field + (and (featurep 'org-table) + org-table-auto-blank-field (memq last-command '(org-cycle org-return org-shifttab org-ctrl-c-ctrl-c)) (if (or (eq (char-after) ?\s) (looking-at "[^|\n]* |")) @@ -19904,10 +16838,16 @@ overwritten, and the table is not marked as requiring realignment." ;; width. (org-table-blank-field))) t) - (looking-at "[^|\n]* \\( \\)|")) + (looking-at "[^|\n]* |")) ;; There is room for insertion without re-aligning the table. - (delete-region (match-beginning 1) (match-end 1)) - (self-insert-command N)) + (self-insert-command N) + (org-table-with-shrunk-field + (save-excursion + (skip-chars-forward "^|") + ;; Do not delete last space, which is + ;; `org-table-separator-space', but the regular space before + ;; it. + (delete-region (- (point) 2) (1- (point)))))) (t (setq org-table-may-need-update t) (self-insert-command N) @@ -19992,12 +16932,11 @@ The detailed reaction depends on the user option `org-catch-invisible-edits'." (defun org-fix-tags-on-the-fly () "Align tags in headline at point. -Unlike to `org-set-tags', it ignores region and sorting." - (when (and (eq (char-after (line-beginning-position)) ?*) ;short-circuit - (org-at-heading-p)) - (let ((org-ignore-region t) - (org-tags-sort-function nil)) - (org-set-tags nil t)))) +Unlike `org-align-tags', this function does nothing if point is +either not currently on a tagged headline or on a tag." + (when (and (org-match-line org-tag-line-re) + (< (point) (match-beginning 1))) + (org-align-tags))) (defun org-delete-backward-char (N) "Like `delete-backward-char', insert whitespace at field end in tables. @@ -20008,22 +16947,14 @@ because, in this case the deletion might narrow the column." (interactive "p") (save-match-data (org-check-before-invisible-edit 'delete-backward) - (if (and (org-at-table-p) - (eq N 1) + (if (and (= N 1) + (not overwrite-mode) (not (org-region-active-p)) - (string-match "|" (buffer-substring (point-at-bol) (point))) - (looking-at ".*?|")) - (let ((pos (point)) - (noalign (looking-at "[^|\n\r]* |")) - (c org-table-may-need-update)) - (backward-delete-char N) - (unless overwrite-mode - (skip-chars-forward "^|") - (insert " ") - (goto-char (1- pos))) - ;; noalign: if there were two spaces at the end, this field - ;; does not determine the width of the column. - (when noalign (setq org-table-may-need-update c))) + (not (eq (char-before) ?|)) + (save-excursion (skip-chars-backward " \t") (not (bolp))) + (looking-at-p ".*?|") + (org-at-table-p)) + (progn (forward-char -1) (org-delete-char 1)) (backward-delete-char N) (org-fix-tags-on-the-fly)))) @@ -20036,23 +16967,28 @@ because, in this case the deletion might narrow the column." (interactive "p") (save-match-data (org-check-before-invisible-edit 'delete) - (if (and (org-at-table-p) - (not (bolp)) - (not (= (char-after) ?|)) - (eq N 1)) - (if (looking-at ".*?|") - (let ((pos (point)) - (noalign (looking-at "[^|\n\r]* |")) - (c org-table-may-need-update)) - (replace-match - (concat (substring (match-string 0) 1 -1) " |") nil t) - (goto-char pos) - ;; noalign: if there were two spaces at the end, this field - ;; does not determine the width of the column. - (when noalign (setq org-table-may-need-update c))) - (delete-char N)) + (cond + ((or (/= N 1) + (eq (char-after) ?|) + (save-excursion (skip-chars-backward " \t") (bolp)) + (not (org-at-table-p))) (delete-char N) - (org-fix-tags-on-the-fly)))) + (org-fix-tags-on-the-fly)) + ((looking-at ".\\(.*?\\)|") + (let* ((update? org-table-may-need-update) + (noalign (looking-at-p ".*? |"))) + (delete-char 1) + (org-table-with-shrunk-field + (save-excursion + ;; Last space is `org-table-separator-space', so insert + ;; a regular one before it instead. + (goto-char (- (match-end 0) 2)) + (insert " "))) + ;; If there were two spaces at the end, this field does not + ;; determine the width of the column. + (when noalign (setq org-table-may-need-update update?)))) + (t + (delete-char N))))) ;; Make `delete-selection-mode' work with Org mode and Orgtbl mode (put 'org-self-insert-command 'delete-selection @@ -20085,7 +17021,6 @@ word constituents." (interactive) (with-syntax-table org-mode-transpose-word-syntax-table (call-interactively 'transpose-words))) -(org-remap org-mode-map 'transpose-words 'org-transpose-words) (defvar org-ctrl-c-ctrl-c-hook nil "Hook for functions attaching themselves to `C-c C-c'. @@ -20403,12 +17338,20 @@ for more information." (cond ((run-hook-with-args-until-success 'org-metaup-hook)) ((org-region-active-p) - (let* ((a (min (region-beginning) (region-end))) - (b (1- (max (region-beginning) (region-end)))) - (c (save-excursion (goto-char a) - (move-beginning-of-line 0))) - (d (save-excursion (goto-char a) - (move-end-of-line 0) (point)))) + (let* ((a (save-excursion + (goto-char (min (region-beginning) (region-end))) + (line-beginning-position))) + (b (save-excursion + (goto-char (max (region-beginning) (region-end))) + (if (bolp) (1- (point)) (line-end-position)))) + (c (save-excursion + (goto-char a) + (move-beginning-of-line 0) + (point))) + (d (save-excursion + (goto-char a) + (move-end-of-line 0) + (point)))) (transpose-regions a b c d) (goto-char c))) ((org-at-table-p) (org-call-with-arg 'org-table-move-row 'up)) @@ -20425,12 +17368,20 @@ commands for more information." (cond ((run-hook-with-args-until-success 'org-metadown-hook)) ((org-region-active-p) - (let* ((a (min (region-beginning) (region-end))) - (b (max (region-beginning) (region-end))) - (c (save-excursion (goto-char b) - (move-beginning-of-line 1))) - (d (save-excursion (goto-char b) - (move-end-of-line 1) (1+ (point))))) + (let* ((a (save-excursion + (goto-char (min (region-beginning) (region-end))) + (line-beginning-position))) + (b (save-excursion + (goto-char (max (region-beginning) (region-end))) + (if (bolp) (1- (point)) (line-end-position)))) + (c (save-excursion + (goto-char b) + (move-beginning-of-line (if (bolp) 1 2)) + (point))) + (d (save-excursion + (goto-char b) + (move-end-of-line (if (bolp) 1 2)) + (point)))) (transpose-regions a b c d) (goto-char d))) ((org-at-table-p) (call-interactively 'org-table-move-row)) @@ -20439,9 +17390,10 @@ commands for more information." (t (org-drag-element-forward)))) (defun org-shiftup (&optional arg) - "Increase item in timestamp or increase priority of current headline. -Calls `org-timestamp-up' or `org-priority-up', or `org-previous-item', -depending on context. See the individual commands for more information." + "Act on current element according to context. +Call `org-timestamp-up' or `org-priority-up', or +`org-previous-item', or `org-table-move-cell-up'. See the +individual commands for more information." (interactive "P") (cond ((run-hook-with-args-until-success 'org-shiftup-hook)) @@ -20457,15 +17409,17 @@ depending on context. See the individual commands for more information." ((and (not org-support-shift-select) (org-at-item-p)) (call-interactively 'org-previous-item)) ((org-clocktable-try-shift 'up arg)) + ((org-at-table-p) (org-table-move-cell-up)) ((run-hook-with-args-until-success 'org-shiftup-final-hook)) (org-support-shift-select (org-call-for-shift-select 'previous-line)) (t (org-shiftselect-error)))) (defun org-shiftdown (&optional arg) - "Decrease item in timestamp or decrease priority of current headline. -Calls `org-timestamp-down' or `org-priority-down', or `org-next-item' -depending on context. See the individual commands for more information." + "Act on current element according to context. +Call `org-timestamp-down' or `org-priority-down', or +`org-next-item', or `org-table-move-cell-down'. See the +individual commands for more information." (interactive "P") (cond ((run-hook-with-args-until-success 'org-shiftdown-hook)) @@ -20481,20 +17435,22 @@ depending on context. See the individual commands for more information." ((and (not org-support-shift-select) (org-at-item-p)) (call-interactively 'org-next-item)) ((org-clocktable-try-shift 'down arg)) + ((org-at-table-p) (org-table-move-cell-down)) ((run-hook-with-args-until-success 'org-shiftdown-final-hook)) (org-support-shift-select (org-call-for-shift-select 'next-line)) (t (org-shiftselect-error)))) (defun org-shiftright (&optional arg) - "Cycle the thing at point or in the current line, depending on context. -Depending on context, this does one of the following: + "Act on the current element according to context. +This does one of the following: - switch a timestamp at point one day into the future - on a headline, switch to the next TODO keyword - on an item, switch entire list to the next bullet type - on a property line, switch to the next allowed value -- on a clocktable definition line, move time block into the future" +- on a clocktable definition line, move time block into the future +- in a table, move a single cell right" (interactive "P") (cond ((run-hook-with-args-until-success 'org-shiftright-hook)) @@ -20517,20 +17473,22 @@ Depending on context, this does one of the following: (org-at-property-p)) (call-interactively 'org-property-next-allowed-value)) ((org-clocktable-try-shift 'right arg)) + ((org-at-table-p) (org-table-move-cell-right)) ((run-hook-with-args-until-success 'org-shiftright-final-hook)) (org-support-shift-select (org-call-for-shift-select 'forward-char)) (t (org-shiftselect-error)))) (defun org-shiftleft (&optional arg) - "Cycle the thing at point or in the current line, depending on context. -Depending on context, this does one of the following: + "Act on current element according to context. +This does one of the following: - switch a timestamp at point one day into the past - on a headline, switch to the previous TODO keyword. - on an item, switch entire list to the previous bullet type - on a property line, switch to the previous allowed value -- on a clocktable definition line, move time block into the past" +- on a clocktable definition line, move time block into the past +- in a table, move a single cell left" (interactive "P") (cond ((run-hook-with-args-until-success 'org-shiftleft-hook)) @@ -20553,6 +17511,7 @@ Depending on context, this does one of the following: (org-at-property-p)) (call-interactively 'org-property-previous-allowed-value)) ((org-clocktable-try-shift 'left arg)) + ((org-at-table-p) (org-table-move-cell-left)) ((run-hook-with-args-until-success 'org-shiftleft-final-hook)) (org-support-shift-select (org-call-for-shift-select 'backward-char)) @@ -20656,7 +17615,9 @@ this numeric value." (let ((next (next-single-char-property-change beg 'invisible nil end))) (setq result (concat result (buffer-substring beg next))) (setq beg next))) - (kill-new result))) + (setq deactivate-mark t) + (kill-new result) + (message "Visible strings have been copied to the kill ring."))) (defun org-copy-special () "Copy region in table or copy current subtree. @@ -20691,7 +17652,10 @@ When in a fixed-width region, call `org-edit-fixed-width-region'. When in an export block, call `org-edit-export-block'. When in a LaTeX environment, call `org-edit-latex-environment'. When at an #+INCLUDE keyword, visit the included file. -When at a footnote reference, call `org-edit-footnote-reference' +When at a footnote reference, call `org-edit-footnote-reference'. +When at a planning line call, `org-deadline' and/or `org-schedule'. +When at an active timestamp, call `org-time-stamp'. +When at an inactive timestamp, call `org-time-stamp-inactive'. On a link, call `ffap' to visit the link at point. Otherwise, return a user error." (interactive "P") @@ -20705,28 +17669,25 @@ Otherwise, return a user error." (params (nth 2 info)) (session (cdr (assq :session params)))) (if (not session) (org-edit-src-code) - ;; At a src-block with a session and function called with - ;; an ARG: switch to the buffer related to the inferior - ;; process. + ;; At a source block with a session and function called + ;; with an ARG: switch to the buffer related to the + ;; inferior process. (switch-to-buffer (funcall (intern (concat "org-babel-prep-session:" lang)) session params)))))) (`keyword - (if (member (org-element-property :key element) '("INCLUDE" "SETUPFILE")) - (org-open-link-from-string - (format "[[%s]]" - (expand-file-name - (let ((value (org-element-property :value element))) - (cond ((org-file-url-p value) - (user-error "The file is specified as a URL, cannot be edited")) - ((not (org-string-nw-p value)) - (user-error "No file to edit")) - ((string-match "\\`\"\\(.*?\\)\"" value) - (match-string 1 value)) - ((string-match "\\`[^ \t\"]\\S-*" value) - (match-string 0 value)) - (t (user-error "No valid file specified"))))))) - (user-error "No special environment to edit here"))) + (unless (member (org-element-property :key element) + '("INCLUDE" "SETUPFILE")) + (user-error "No special environment to edit here")) + (let ((value (org-element-property :value element))) + (unless (org-string-nw-p value) (user-error "No file to edit")) + (let ((file (and (string-match "\\`\"\\(.*?\\)\"\\|\\S-+" value) + (or (match-string 1 value) + (match-string 0 value))))) + (when (org-file-url-p file) + (user-error "Files located with a URL cannot be edited")) + (org-link-open-from-string + (format "[[%s]]" (expand-file-name file)))))) (`table (if (eq (org-element-property :type element) 'table.el) (org-edit-table.el) @@ -20737,6 +17698,13 @@ Otherwise, return a user error." (`export-block (org-edit-export-block)) (`fixed-width (org-edit-fixed-width-region)) (`latex-environment (org-edit-latex-environment)) + (`planning + (let ((proplist (cadr element))) + (mapc #'call-interactively + (remq nil + (list + (when (plist-get proplist :deadline) #'org-deadline) + (when (plist-get proplist :scheduled) #'org-schedule)))))) (_ ;; No notable element at point. Though, we may be at a link or ;; a footnote reference, which are objects. Thus, scan deeper. @@ -20744,10 +17712,12 @@ Otherwise, return a user error." (pcase (org-element-type context) (`footnote-reference (org-edit-footnote-reference)) (`inline-src-block (org-edit-inline-src-code)) + (`timestamp (if (eq 'inactive (org-element-property :type context)) + (call-interactively #'org-time-stamp-inactive) + (call-interactively #'org-time-stamp))) (`link (call-interactively #'ffap)) (_ (user-error "No special environment to edit here")))))))) -(defvar org-table-coordinate-overlays) ; defined in org-table.el (defun org-ctrl-c-ctrl-c (&optional arg) "Set tags in headline, or update according to changed information at point. @@ -20828,7 +17798,7 @@ This command does many different things, depending on context: ;; Act according to type of element or object at point. ;; ;; Do nothing on a blank line, except if it is contained in - ;; a src block. Hence, we first check if point is in such + ;; a source block. Hence, we first check if point is in such ;; a block and then if it is at a blank line. (pcase type ((or `inline-src-block `src-block) @@ -20855,7 +17825,7 @@ This command does many different things, depending on context: (`footnote-reference (call-interactively #'org-footnote-action)) ((or `headline `inlinetask) (save-excursion (goto-char (org-element-property :begin context)) - (call-interactively #'org-set-tags))) + (call-interactively #'org-set-tags-command))) (`item ;; At an item: `C-u C-u' sets checkbox to "[-]" ;; unconditionally, whereas `C-u' will toggle its presence. @@ -20909,7 +17879,6 @@ This command does many different things, depending on context: ;; first item in the list. Without an argument, repair the ;; list. (let* ((begin (org-element-property :contents-begin context)) - (beginm (move-marker (make-marker) begin)) (struct (org-element-property :structure context)) (old-struct (copy-tree struct)) (first-box (save-excursion @@ -20931,10 +17900,12 @@ This command does many different things, depending on context: ;; item of the list and no argument is provided, simply ;; toggle checkbox of that item, if any. (org-list-set-checkbox begin struct new-box))) - (org-list-write-struct - struct (org-list-parents-alist struct) old-struct) - (org-update-checkbox-count-maybe) - (save-excursion (goto-char beginm) (org-list-send-list 'maybe)))) + (when (equal + (org-list-write-struct + struct (org-list-parents-alist struct) old-struct) + old-struct) + (message "Cannot update this checkbox")) + (org-update-checkbox-count-maybe))) ((or `property-drawer `node-property) (call-interactively #'org-property-action)) (`radio-target @@ -20969,7 +17940,7 @@ Use `\\[org-edit-special]' to edit table.el tables")) ((and `nil (guard (org-at-heading-p))) ;; When point is on an unsupported object type, we can miss ;; the fact that it also is at a heading. Handle it here. - (call-interactively #'org-set-tags)) + (call-interactively #'org-set-tags-command)) ((guard (run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-final-hook))) (_ @@ -20987,18 +17958,35 @@ Use `\\[org-edit-special]' to edit table.el tables")) (org-reset-file-cache)) (message "%s restarted" major-mode)) +(defun org-flag-above-first-heading (&optional arg) + "Hide from bob up to the first heading. +Move point to the beginning of first heading or end of buffer." + (goto-char (point-min)) + (unless (org-at-heading-p) + (outline-next-heading)) + (unless (bobp) + (org-flag-region 1 (1- (point)) (not arg) 'outline))) + +(defun org-show-branches-buffer () + "Show all branches in the buffer." + (org-flag-above-first-heading) + (outline-hide-sublevels 1) + (unless (eobp) + (outline-show-branches) + (while (outline-get-next-sibling) + (outline-show-branches))) + (goto-char (point-min))) + (defun org-kill-note-or-show-branches () - "Abort storing current note, or call `outline-show-branches'." + "Abort storing current note, or show just branches." (interactive) - (if (not org-finish-function) - (save-excursion - (save-restriction - (org-narrow-to-subtree) - (org-flag-subtree t) - (call-interactively 'outline-show-branches) - (org-hide-archived-subtrees (point-min) (point-max)))) - (let ((org-note-abort t)) - (funcall org-finish-function)))) + (if org-finish-function + (let ((org-note-abort t)) + (funcall org-finish-function)) + (if (org-before-first-heading-p) + (org-show-branches-buffer) + (outline-hide-subtree) + (outline-show-branches)))) (defun org-delete-indentation (&optional arg) "Join current line to previous and fix whitespace at join. @@ -21029,7 +18017,7 @@ With a non-nil optional argument, join it to the following one." ;; Adjust alignment of tags. (cond ((not tags-column)) ;no tags - (org-auto-align-tags (org-set-tags nil t)) + (org-auto-align-tags (org-align-tags)) (t (org--align-tags-here tags-column)))) ;preserve tags column (delete-indentation arg))) @@ -21062,7 +18050,8 @@ object (e.g., within a comment). In these case, you need to use (cond ;; In a table, call `org-table-next-row'. However, before first ;; column or after last one, split the table. - ((or (and (eq (org-element-type context) 'table) + ((or (and (eq 'table (org-element-type context)) + (not (eq 'table.el (org-element-property :type context))) (>= (point) (org-element-property :contents-begin context)) (< (point) (org-element-property :contents-end context))) (org-element-lineage context '(table-row table-cell) t)) @@ -21075,15 +18064,21 @@ object (e.g., within a comment). In these case, you need to use ;; `org-return-follows-link' allows it. Tolerate fuzzy ;; locations, e.g., in a comment, as `org-open-at-point'. ((and org-return-follows-link - (or (org-in-regexp org-ts-regexp-both nil t) + (or (and (eq 'link (org-element-type context)) + ;; Ensure point is not on the white spaces after + ;; the link. + (let ((origin (point))) + (org-with-point-at (org-element-property :end context) + (skip-chars-backward " \t") + (> (point) origin)))) + (org-in-regexp org-ts-regexp-both nil t) (org-in-regexp org-tsr-regexp-both nil t) - (org-in-regexp org-any-link-re nil t))) + (org-in-regexp org-link-any-re nil t))) (call-interactively #'org-open-at-point)) ;; Insert newline in heading, but preserve tags. ((and (not (bolp)) - (save-excursion (beginning-of-line) - (let ((case-fold-search nil)) - (looking-at org-complex-heading-regexp)))) + (let ((case-fold-search nil)) + (org-match-line org-complex-heading-regexp))) ;; At headline. Split line. However, if point is on keyword, ;; priority cookie or tags, do not break any of them: add ;; a newline after the headline instead. @@ -21096,7 +18091,7 @@ object (e.g., within a comment). In these case, you need to use ;; Adjust tag alignment. (cond ((not (and tags-column string))) - (org-auto-align-tags (org-set-tags nil t)) + (org-auto-align-tags (org-align-tags)) (t (org--align-tags-here tags-column))) ;preserve tags column (end-of-line) (org-show-entry) @@ -21125,6 +18120,21 @@ context. See the individual commands for more information." (interactive) (org-return t)) +(defun org-ctrl-c-tab (&optional arg) + "Toggle columns width in a table, or show children. +Call `org-table-toggle-column-width' if point is in a table. +Otherwise, call `org-show-children'. ARG is the level to hide." + (interactive "p") + (if (org-at-table-p) + (call-interactively #'org-table-toggle-column-width) + (if (org-before-first-heading-p) + (progn + (org-flag-above-first-heading) + (outline-hide-sublevels (or arg 1)) + (goto-char (point-min))) + (outline-hide-subtree) + (org-show-children arg)))) + (defun org-ctrl-c-star () "Compute table, or change heading status of lines. Calls `org-table-recalculate' or `org-toggle-heading', @@ -21226,7 +18236,12 @@ number of stars to add." (min (org-list-get-bottom-point struct) (1+ end)))) (save-restriction (narrow-to-region (point) list-end) - (insert (org-list-to-subtree (org-list-to-lisp t)) "\n"))) + (insert (org-list-to-subtree + (org-list-to-lisp t) + (pcase (org-current-level) + (`nil 1) + (l (1+ (org-reduced-level l))))) + "\n"))) (setq toggled t)) (forward-line))) ;; Case 3. Started at normal text: make every line an heading, @@ -21235,10 +18250,10 @@ number of stars to add." (make-string (if (numberp nstars) nstars (or (org-current-level) 0)) ?*)) (add-stars - (cond (nstars "") ; stars from prefix only - ((equal stars "") "*") ; before first heading + (cond (nstars "") ; stars from prefix only + ((equal stars "") "*") ; before first heading (org-odd-levels-only "**") ; inside heading, odd - (t "*"))) ; inside heading, oddeven + (t "*"))) ; inside heading, oddeven (rpl (concat stars add-stars " ")) (lend (when (listp nstars) (save-excursion (end-of-line) (point))))) (while (< (point) (if (equal nstars '(4)) lend end)) @@ -21284,7 +18299,8 @@ an argument, unconditionally call `org-insert-heading'." ["Move Column Left" org-metaleft (org-at-table-p)] ["Move Column Right" org-metaright (org-at-table-p)] ["Delete Column" org-shiftmetaleft (org-at-table-p)] - ["Insert Column" org-shiftmetaright (org-at-table-p)]) + ["Insert Column" org-shiftmetaright (org-at-table-p)] + ["Shrink Column" org-table-toggle-column-width (org-at-table-p)]) ("Row" ["Move Row Up" org-metaup (org-at-table-p)] ["Move Row Down" org-metadown (org-at-table-p)] @@ -21339,7 +18355,7 @@ an argument, unconditionally call `org-insert-heading'." ["Cycle Global Visibility" org-shifttab :active (not (org-at-table-p))] ["Sparse Tree..." org-sparse-tree t] ["Reveal Context" org-reveal t] - ["Show All" outline-show-all t] + ["Show All" org-show-all t] "--" ["Subtree to indirect buffer" org-tree-to-indirect-buffer t]) "--" @@ -21513,7 +18529,8 @@ an argument, unconditionally call `org-insert-heading'." "--" ("Documentation" ["Show Version" org-version t] - ["Info Documentation" org-info t]) + ["Info Documentation" org-info t] + ["Browse Org News" org-browse-news t]) ("Customize" ["Browse Org Group" org-customize t] "--" @@ -21524,8 +18541,7 @@ an argument, unconditionally call `org-insert-heading'." ("Refresh/Reload" ["Refresh setup current buffer" org-mode-restart t] ["Reload Org (after update)" org-reload t] - ["Reload Org uncompiled" (org-reload t) :active t :keys "C-u C-c C-x !"]) - )) + ["Reload Org uncompiled" (org-reload t) :active t :keys "C-u C-c C-x !"]))) (defun org-info (&optional node) "Read documentation for Org in the info system. @@ -21533,6 +18549,11 @@ With optional NODE, go directly to that node." (interactive) (info (format "(org)%s" (or node "")))) +(defun org-browse-news () + "Browse the news for the latest major release." + (interactive) + (browse-url "https://orgmode.org/Changes.html")) + ;;;###autoload (defun org-submit-bug-report () "Submit a bug report on Org via mail. @@ -21705,26 +18726,6 @@ With prefix arg UNCOMPILED, load the uncompiled versions." ;;; Generally useful functions -(defun org-get-at-eol (property n) - "Get text property PROPERTY at the end of line less N characters." - (get-text-property (- (point-at-eol) n) property)) - -(defun org-find-text-property-in-string (prop s) - "Return the first non-nil value of property PROP in string S." - (or (get-text-property 0 prop s) - (get-text-property (or (next-single-property-change 0 prop s) 0) - prop s))) - -(defun org-display-warning (message) - "Display the given MESSAGE as a warning." - (display-warning 'org message :warning)) - -(defun org-eval (form) - "Eval FORM and return result." - (condition-case error - (eval form) - (error (format "%%![Error: %s]" error)))) - (defun org-in-clocktable-p () "Check if the cursor is in a clocktable." (let ((pos (point)) start) @@ -21742,27 +18743,6 @@ With prefix arg UNCOMPILED, load the uncompiled versions." (>= (point) (match-beginning 3)) (<= (point) (match-end 4))))) -(defun org-overlay-display (ovl text &optional face evap) - "Make overlay OVL display TEXT with face FACE." - (overlay-put ovl 'display text) - (if face (overlay-put ovl 'face face)) - (if evap (overlay-put ovl 'evaporate t))) - -(defun org-overlay-before-string (ovl text &optional face evap) - "Make overlay OVL display TEXT with face FACE." - (if face (org-add-props text nil 'face face)) - (overlay-put ovl 'before-string text) - (if evap (overlay-put ovl 'evaporate t))) - -(defun org-find-overlays (prop &optional pos delete) - "Find all overlays specifying PROP at POS or point. -If DELETE is non-nil, delete all those overlays." - (let (found) - (dolist (ov (overlays-at (or pos (point))) found) - (cond ((not (overlay-get ov prop))) - (delete (delete-overlay ov)) - (t (push ov found)))))) - (defun org-goto-marker-or-bmk (marker &optional bookmark) "Go to MARKER, widen if necessary. When marker is not live, try BOOKMARK." (if (and marker (marker-buffer marker) @@ -21788,158 +18768,6 @@ If DELETE is non-nil, delete all those overlays." (interactive "p") (self-insert-command N)) -(defun org-shorten-string (s maxlength) - "Shorten string S so that it is no longer than MAXLENGTH characters. -If the string is shorter or has length MAXLENGTH, just return the -original string. If it is longer, the functions finds a space in the -string, breaks this string off at that locations and adds three dots -as ellipsis. Including the ellipsis, the string will not be longer -than MAXLENGTH. If finding a good breaking point in the string does -not work, the string is just chopped off in the middle of a word -if necessary." - (if (<= (length s) maxlength) - s - (let* ((n (max (- maxlength 4) 1)) - (re (concat "\\`\\(.\\{1," (int-to-string n) "\\}[^ ]\\)\\([ ]\\|\\'\\)"))) - (if (string-match re s) - (concat (match-string 1 s) "...") - (concat (substring s 0 (max (- maxlength 3) 0)) "..."))))) - -(defun org-get-indentation (&optional line) - "Get the indentation of the current line, interpreting tabs. -When LINE is given, assume it represents a line and compute its indentation." - (if line - (when (string-match "^ *" (org-remove-tabs line)) - (match-end 0)) - (save-excursion - (beginning-of-line 1) - (skip-chars-forward " \t") - (current-column)))) - -(defun org-get-string-indentation (s) - "What indentation has S due to SPACE and TAB at the beginning of the string?" - (let ((n -1) (i 0) (w tab-width) c) - (catch 'exit - (while (< (setq n (1+ n)) (length s)) - (setq c (aref s n)) - (cond ((= c ?\ ) (setq i (1+ i))) - ((= c ?\t) (setq i (* (/ (+ w i) w) w))) - (t (throw 'exit t))))) - i)) - -(defun org-remove-tabs (s &optional width) - "Replace tabulators in S with spaces. -Assumes that s is a single line, starting in column 0." - (setq width (or width tab-width)) - (while (string-match "\t" s) - (setq s (replace-match - (make-string - (- (* width (/ (+ (match-beginning 0) width) width)) - (match-beginning 0)) ?\ ) - t t s))) - s) - -(defun org-fix-indentation (line ind) - "Fix indentation in LINE. -IND is a cons cell with target and minimum indentation. -If the current indentation in LINE is smaller than the minimum, -leave it alone. If it is larger than ind, set it to the target." - (let* ((l (org-remove-tabs line)) - (i (org-get-indentation l)) - (i1 (car ind)) (i2 (cdr ind))) - (when (>= i i2) (setq l (substring line i2))) - (if (> i1 0) - (concat (make-string i1 ?\ ) l) - l))) - -(defun org-remove-indentation (code &optional n) - "Remove maximum common indentation in string CODE and return it. -N may optionally be the number of columns to remove. Return CODE -as-is if removal failed." - (with-temp-buffer - (insert code) - (if (org-do-remove-indentation n) (buffer-string) code))) - -(defun org-do-remove-indentation (&optional n) - "Remove the maximum common indentation from the buffer. -When optional argument N is a positive integer, remove exactly -that much characters from indentation, if possible. Return nil -if it fails." - (catch :exit - (goto-char (point-min)) - ;; Find maximum common indentation, if not specified. - (let ((n (or n - (let ((min-ind (point-max))) - (save-excursion - (while (re-search-forward "^[ \t]*\\S-" nil t) - (let ((ind (1- (current-column)))) - (if (zerop ind) (throw :exit nil) - (setq min-ind (min min-ind ind)))))) - min-ind)))) - (if (zerop n) (throw :exit nil) - ;; Remove exactly N indentation, but give up if not possible. - (while (not (eobp)) - (let ((ind (progn (skip-chars-forward " \t") (current-column)))) - (cond ((eolp) (delete-region (line-beginning-position) (point))) - ((< ind n) (throw :exit nil)) - (t (indent-line-to (- ind n)))) - (forward-line))) - ;; Signal success. - t)))) - -(defun org-fill-template (template alist) - "Find each %key of ALIST in TEMPLATE and replace it." - (let ((case-fold-search nil)) - (dolist (entry (sort (copy-sequence alist) - (lambda (a b) (< (length (car a)) (length (car b)))))) - (setq template - (replace-regexp-in-string - (concat "%" (regexp-quote (car entry))) - (or (cdr entry) "") template t t))) - template)) - -(defun org-base-buffer (buffer) - "Return the base buffer of BUFFER, if it has one. Else return the buffer." - (if (not buffer) - buffer - (or (buffer-base-buffer buffer) - buffer))) - -(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 -that costs. If there is a word longer than WIDTH, the text is actually -wrapped to the length of that word. -IF WIDTH is nil and LINES is non-nil, the string is forced into at most that -many lines, whatever width that takes. -The return value is a list of lines, without newlines at the end." - (let* ((words (split-string string)) - (maxword (apply 'max (mapcar 'org-string-width words))) - w ll) - (cond (width - (org-do-wrap words (max maxword width))) - (lines - (setq w maxword) - (setq ll (org-do-wrap words maxword)) - (if (<= (length ll) lines) - ll - (setq ll words) - (while (> (length ll) lines) - (setq w (1+ w)) - (setq ll (org-do-wrap words w))) - ll)) - (t (error "Cannot wrap this"))))) - -(defun org-do-wrap (words width) - "Create lines of maximum width WIDTH (in characters) from word list WORDS." - (let (lines line) - (while words - (setq line (pop words)) - (while (and words (< (+ (length line) (length (car words))) width)) - (setq line (concat line " " (pop words)))) - (setq lines (push line lines))) - (nreverse lines))) - (defun org-quote-vert (s) "Replace \"|\" with \"\\vert\"." (while (string-match "|" s) @@ -21952,8 +18780,8 @@ The return value is a list of lines, without newlines at the end." (defun org-in-src-block-p (&optional inside) "Whether point is in a code source block. -When INSIDE is non-nil, don't consider we are within a src block -when point is at #+BEGIN_SRC or #+END_SRC." +When INSIDE is non-nil, don't consider we are within a source +block when point is at #+BEGIN_SRC or #+END_SRC." (let ((case-fold-search t)) (or (and (eq (get-char-property (point) 'src-block) t)) (and (not inside) @@ -21984,8 +18812,6 @@ contexts are: :src-block in a source block :link on a hyperlink :keyword on a keyword: SCHEDULED, DEADLINE, CLOSE, COMMENT. -:target on a <<target>> -:radio-target on a <<<radio-target>>> :latex-fragment on a LaTeX fragment :latex-preview on a LaTeX fragment with overlaid preview image @@ -22059,12 +18885,6 @@ and :keyword." (push (list :keyword (previous-single-property-change p 'face) (next-single-property-change p 'face)) clist)) - ((org-at-target-p) - (push (org-point-in-group p 0 :target) clist) - (goto-char (1- (match-beginning 0))) - (when (looking-at org-radio-target-regexp) - (push (org-point-in-group p 0 :radio-target) clist)) - (goto-char p)) ((setq o (cl-some (lambda (o) (and (eq (overlay-get o 'org-overlay-type) 'org-latex-overlay) @@ -22081,28 +18901,6 @@ and :keyword." (setq clist (nreverse (delq nil clist))) clist)) -(defun org-in-regexp (regexp &optional nlines visually) - "Check if point is inside a match of REGEXP. - -Normally only the current line is checked, but you can include -NLINES extra lines around point into the search. If VISUALLY is -set, require that the cursor is not after the match but really -on, so that the block visually is on the match. - -Return nil or a cons cell (BEG . END) where BEG and END are, -respectively, the positions at the beginning and the end of the -match." - (catch :exit - (let ((pos (point)) - (eol (line-end-position (if nlines (1+ nlines) 1)))) - (save-excursion - (beginning-of-line (- 1 (or nlines 0))) - (while (and (re-search-forward regexp eol t) - (<= (match-beginning 0) pos)) - (let ((end (match-end 0))) - (when (or (> end pos) (and (= end pos) (not visually))) - (throw :exit (cons (match-beginning 0) (match-end 0)))))))))) - (defun org-between-regexps-p (start-re end-re &optional lim-up lim-down) "Non-nil when point is between matches of START-RE and END-RE. @@ -22194,40 +18992,6 @@ for the search purpose." (error "Unable to create a link to here")))) (org-occur-in-agenda-files (regexp-quote link)))) -(defun org-reverse-string (string) - "Return the reverse of STRING." - (apply 'string (reverse (string-to-list string)))) - -;; defsubst org-uniquify must be defined before first use - -(defun org-uniquify-alist (alist) - "Merge elements of ALIST with the same key. - -For example, in this alist: - -\(org-uniquify-alist \\='((a 1) (b 2) (a 3))) - => \\='((a 1 3) (b 2)) - -merge (a 1) and (a 3) into (a 1 3). - -The function returns the new ALIST." - (let (rtn) - (dolist (e alist rtn) - (let (n) - (if (not (assoc (car e) rtn)) - (push e rtn) - (setq n (cons (car e) (append (cdr (assoc (car e) rtn)) (cdr e)))) - (setq rtn (assq-delete-all (car e) rtn)) - (push n rtn)))))) - -(defun org-delete-all (elts list) - "Remove all elements in ELTS from LIST. -Comparison is done with `equal'. It is a destructive operation -that may remove elements by altering the list structure." - (while elts - (setq list (delete (pop elts) list))) - list) - (defun org-back-over-empty-lines () "Move backwards over whitespace, to the beginning of the first empty line. Returns the number of empty lines passed." @@ -22240,78 +19004,6 @@ Returns the number of empty lines passed." (goto-char (min (point) pos)) (count-lines (point) pos))) -(defun org-skip-whitespace () - (skip-chars-forward " \t\n\r")) - -(defun org-point-in-group (point group &optional context) - "Check if POINT is in match-group GROUP. -If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the -match. If the match group does not exist or point is not inside it, -return nil." - (and (match-beginning group) - (>= point (match-beginning group)) - (<= point (match-end group)) - (if context - (list context (match-beginning group) (match-end group)) - t))) - -(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))) - -(defun org-combine-plists (&rest plists) - "Create a single property list from all plists in PLISTS. -The process starts by copying the first list, and then setting properties -from the other lists. Settings in the last list are the most significant -ones and overrule settings in the other lists." - (let ((rtn (copy-sequence (pop plists))) - p v ls) - (while plists - (setq ls (pop plists)) - (while ls - (setq p (pop ls) v (pop ls)) - (setq rtn (plist-put rtn p v)))) - rtn)) - -(defun org-replace-escapes (string table) - "Replace %-escapes in STRING with values in TABLE. -TABLE is an association list with keys like \"%a\" and string values. -The sequences in STRING may contain normal field width and padding information, -for example \"%-5s\". Replacements happen in the sequence given by TABLE, -so values can contain further %-escapes if they are define later in TABLE." - (let ((tbl (copy-alist table)) - (case-fold-search nil) - (pchg 0) - re rpl) - (dolist (e tbl) - (setq re (concat "%-?[0-9.]*" (substring (car e) 1))) - (when (and (cdr e) (string-match re (cdr e))) - (let ((sref (substring (cdr e) (match-beginning 0) (match-end 0))) - (safe "SREF")) - (add-text-properties 0 3 (list 'sref sref) safe) - (setcdr e (replace-match safe t t (cdr e))))) - (while (string-match re string) - (setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s") - (cdr e))) - (setq string (replace-match rpl t t string)))) - (while (setq pchg (next-property-change pchg string)) - (let ((sref (get-text-property pchg 'sref string))) - (when (and sref (string-match "SREF" string pchg)) - (setq string (replace-match sref t t string))))) - string)) - -(defun org-find-base-buffer-visiting (file) - "Like `find-buffer-visiting' but always return the base buffer and -not an indirect buffer." - (let ((buf (or (get-file-buffer file) - (find-buffer-visiting file)))) - (if buf - (or (buffer-base-buffer buf) buf) - nil))) - ;;; TODO: Only called once, from ox-odt which should probably use ;;; org-export-inline-image-p or something. (defun org-file-image-p (file) @@ -22324,7 +19016,9 @@ not an indirect buffer." This works in the calendar and in the agenda, anywhere else it just returns the current time. If WITH-TIME is non-nil, returns the time of the event at point (in -the agenda) or the current time of the day." +the agenda) or the current time of the day; otherwise returns the +earliest time on the cursor date that Org treats as that date +(bearing in mind `org-extend-today-until')." (let (date day defd tp hod mod) (when with-time (setq tp (get-text-property (point) 'time)) @@ -22337,13 +19031,13 @@ the agenda) or the current time of the day." (cond ((eq major-mode 'calendar-mode) (setq date (calendar-cursor-to-date) - defd (encode-time 0 (or mod 0) (or hod 0) + defd (encode-time 0 (or mod 0) (or hod org-extend-today-until) (nth 1 date) (nth 0 date) (nth 2 date)))) ((eq major-mode 'org-agenda-mode) (setq day (get-text-property (point) 'day)) (when day (setq date (calendar-gregorian-from-absolute day) - defd (encode-time 0 (or mod 0) (or hod 0) + defd (encode-time 0 (or mod 0) (or hod org-extend-today-until) (nth 1 date) (nth 0 date) (nth 2 date)))))) (or defd (current-time)))) @@ -22362,75 +19056,6 @@ hierarchy of headlines by UP levels before marking the subtree." (call-interactively 'org-mark-element) (org-mark-element))) -(defun org-file-newer-than-p (file time) - "Non-nil if FILE is newer than TIME. -FILE is a filename, as a string, TIME is a list of integers, as -returned by, e.g., `current-time'." - (and (file-exists-p file) - ;; Only compare times up to whole seconds as some file-systems - ;; (e.g. HFS+) do not retain any finer granularity. As - ;; a consequence, make sure we return non-nil when the two - ;; times are equal. - (not (time-less-p (cl-subseq (file-attribute-modification-time - (file-attributes file)) - 0 2) - (cl-subseq time 0 2))))) - -(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)) - (out-dir (or (file-name-directory source) "./")) - (output (expand-file-name (concat base-name "." ext) out-dir)) - (time (current-time)) - (err-msg (if (stringp err-msg) (concat ". " err-msg) ""))) - (save-window-excursion - (pcase process - ((pred functionp) (funcall process (shell-quote-argument source))) - ((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 source)) - (?F . ,(shell-quote-argument full-name)) - (?o . ,(shell-quote-argument out-dir)) - (?O . ,(shell-quote-argument output)))))) - (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 (defvar org-element-greater-elements) @@ -22454,7 +19079,7 @@ ELEMENT." ((item plain-list) (org-list-item-body-column post-affiliated)) (t (goto-char start) - (org-get-indentation)))) + (current-indentation)))) ((memq type '(headline inlinetask nil)) (if (org-match-line "[ \t]*$") (org--get-expected-indentation element t) @@ -22487,7 +19112,7 @@ ELEMENT." (setq start (org-element-property :begin previous))) (t (goto-char (org-element-property :begin previous)) (throw 'exit - (if (bolp) (org-get-indentation) + (if (bolp) (current-indentation) ;; At first paragraph in an item or ;; a footnote definition. (org--get-expected-indentation @@ -22506,7 +19131,7 @@ ELEMENT." ((and (memq type '(footnote-definition plain-list)) (> (count-lines (point) pos) 2)) (goto-char start) - (org-get-indentation)) + (current-indentation)) ;; Line above is the first one of a paragraph at the ;; beginning of an item or a footnote definition. Indent ;; like parent. @@ -22533,9 +19158,9 @@ ELEMENT." (org--get-expected-indentation last (eq (org-element-type last) 'item))) (goto-char start) - (org-get-indentation))) + (current-indentation))) ;; In any other case, indent like the current line. - (t (org-get-indentation))))))))) + (t (current-indentation))))))))) (defun org--align-node-property () "Align node property at point. @@ -22564,10 +19189,8 @@ Indentation is done according to the following rules: definitions and inline tasks, indent like its first line. 2. If element has a parent, indent like its contents. More - precisely, if parent is an item, indent after the - description part, if any, or the bullet (see - `org-list-description-max-indent'). Else, indent like - parent's first line. + precisely, if parent is an item, indent after the bullet. + Else, indent like parent's first line. 3. Otherwise, indent relatively to current level, if `org-adapt-indentation' is non-nil, or to left margin. @@ -22596,10 +19219,6 @@ list structure. Instead, use \\<org-mode-map>`\\[org-shiftmetaleft]' or \ Also align node properties according to `org-property-format'." (interactive) (cond - (orgstruct-is-++ - (let ((indent-line-function - (cl-cadadr (assq 'indent-line-function org-fb-vars)))) - (indent-according-to-mode))) ((org-at-heading-p) 'noindent) (t (let* ((element (save-excursion (beginning-of-line) (org-element-at-point))) @@ -22675,7 +19294,7 @@ assumed to be significant there." (not (or org-src-preserve-indentation (org-element-property :preserve-indent element))))) - (let ((offset (- ind (org-get-indentation)))) + (let ((offset (- ind (current-indentation)))) (unless (zerop offset) (indent-rigidly (org-element-property :begin element) (org-element-property :end element) @@ -22731,7 +19350,7 @@ assumed to be significant there." ;; might break the list as a whole. On the other ;; hand, when at a plain list, indent it as a whole. (cond ((eq type 'plain-list) - (let ((offset (- ind (org-get-indentation)))) + (let ((offset (- ind (current-indentation)))) (unless (zerop offset) (indent-rigidly (org-element-property :begin element) (org-element-property :end element) @@ -22849,78 +19468,63 @@ assumed to be significant there." ;; parenthesis can end up being parsed as a new list item. (looking-at-p "[ \t]*{{{n\\(?:([^\n)]*)\\)?}}}[.)]\\(?:$\\| \\)")) -(declare-function message-in-body-p "message" ()) -(defvar orgtbl-line-start-regexp) ; From org-table.el (defun org-adaptive-fill-function () "Compute a fill prefix for the current line. Return fill prefix, as a string, or nil if current line isn't meant to be filled. For convenience, if `adaptive-fill-regexp' matches in paragraphs or comments, use it." - (catch 'exit - (when (derived-mode-p 'message-mode) - (save-excursion - (beginning-of-line) - (cond ((not (message-in-body-p)) (throw 'exit nil)) - ((looking-at-p org-table-line-regexp) (throw 'exit nil)) - ((looking-at message-cite-prefix-regexp) - (throw 'exit (match-string-no-properties 0))) - ((looking-at org-outline-regexp) - (throw 'exit (make-string (length (match-string 0)) ?\s)))))) - (org-with-wide-buffer - (unless (org-at-heading-p) - (let* ((p (line-beginning-position)) - (element (save-excursion - (beginning-of-line) - (org-element-at-point))) - (type (org-element-type element)) - (post-affiliated (org-element-property :post-affiliated element))) - (unless (< p post-affiliated) - (cl-case type - (comment + (org-with-wide-buffer + (unless (org-at-heading-p) + (let* ((p (line-beginning-position)) + (element (save-excursion + (beginning-of-line) + (org-element-at-point))) + (type (org-element-type element)) + (post-affiliated (org-element-property :post-affiliated element))) + (unless (< p post-affiliated) + (cl-case type + (comment + (save-excursion + (beginning-of-line) + (looking-at "[ \t]*") + (concat (match-string 0) "# "))) + (footnote-definition "") + ((item plain-list) + (make-string (org-list-item-body-column post-affiliated) ?\s)) + (paragraph + ;; Fill prefix is usually the same as the current line, + ;; unless the paragraph is at the beginning of an item. + (let ((parent (org-element-property :parent element))) (save-excursion (beginning-of-line) - (looking-at "[ \t]*") - (concat (match-string 0) "# "))) - (footnote-definition "") - ((item plain-list) - (make-string (org-list-item-body-column post-affiliated) ?\s)) - (paragraph - ;; Fill prefix is usually the same as the current line, - ;; unless the paragraph is at the beginning of an item. - (let ((parent (org-element-property :parent element))) - (save-excursion - (beginning-of-line) - (cond ((eq (org-element-type parent) 'item) - (make-string (org-list-item-body-column - (org-element-property :begin parent)) - ?\s)) - ((and adaptive-fill-regexp - ;; Locally disable - ;; `adaptive-fill-function' to let - ;; `fill-context-prefix' handle - ;; `adaptive-fill-regexp' variable. - (let (adaptive-fill-function) - (fill-context-prefix - post-affiliated - (org-element-property :end element))))) - ((looking-at "[ \t]+") (match-string 0)) - (t ""))))) - (comment-block - ;; Only fill contents if P is within block boundaries. - (let* ((cbeg (save-excursion (goto-char post-affiliated) - (forward-line) - (point))) - (cend (save-excursion - (goto-char (org-element-property :end element)) - (skip-chars-backward " \r\t\n") - (line-beginning-position)))) - (when (and (>= p cbeg) (< p cend)) - (if (save-excursion (beginning-of-line) (looking-at "[ \t]+")) - (match-string 0) - ""))))))))))) - -(declare-function message-goto-body "message" (&optional interactive)) -(defvar message-cite-prefix-regexp) ; From message.el + (cond ((eq (org-element-type parent) 'item) + (make-string (org-list-item-body-column + (org-element-property :begin parent)) + ?\s)) + ((and adaptive-fill-regexp + ;; Locally disable + ;; `adaptive-fill-function' to let + ;; `fill-context-prefix' handle + ;; `adaptive-fill-regexp' variable. + (let (adaptive-fill-function) + (fill-context-prefix + post-affiliated + (org-element-property :end element))))) + ((looking-at "[ \t]+") (match-string 0)) + (t ""))))) + (comment-block + ;; Only fill contents if P is within block boundaries. + (let* ((cbeg (save-excursion (goto-char post-affiliated) + (forward-line) + (point))) + (cend (save-excursion + (goto-char (org-element-property :end element)) + (skip-chars-backward " \r\t\n") + (line-beginning-position)))) + (when (and (>= p cbeg) (< p cend)) + (if (save-excursion (beginning-of-line) (looking-at "[ \t]+")) + (match-string 0) + "")))))))))) (defun org-fill-element (&optional justify) "Fill element at point, when applicable. @@ -22944,7 +19548,7 @@ a footnote definition, try to fill the first paragraph within." ;; First check if point is in a blank line at the beginning of ;; the buffer. In that case, ignore filling. (cl-case (org-element-type element) - ;; Use major mode filling function is src blocks. + ;; Use major mode filling function is source blocks. (src-block (org-babel-do-key-sequence-in-edit-buffer (kbd "M-q"))) ;; Align Org tables, leave table.el tables as-is. (table-row (org-table-align) t) @@ -22962,15 +19566,6 @@ a footnote definition, try to fill the first paragraph within." (org-element-property :contents-end element)))) ;; Do nothing if point is at an affiliated keyword. (if (< (line-end-position) beg) t - (when (derived-mode-p 'message-mode) - ;; In `message-mode', do not fill following citation - ;; in current paragraph nor text before message body. - (let ((body-start (save-excursion (message-goto-body)))) - (when body-start (setq beg (max body-start beg)))) - (when (save-excursion - (re-search-forward - (concat "^" message-cite-prefix-regexp) end t)) - (setq end (match-beginning 0)))) ;; Fill paragraph, taking line breaks into account. (save-excursion (goto-char beg) @@ -23063,34 +19658,28 @@ fill each of the elements in the active region, instead of just filling the current element." (interactive (progn (barf-if-buffer-read-only) - (list (if current-prefix-arg 'full) t))) - (cond - ((and (derived-mode-p 'message-mode) - (or (not (message-in-body-p)) - (save-excursion (move-beginning-of-line 1) - (looking-at message-cite-prefix-regexp)))) - ;; First ensure filling is correct in message-mode. - (let ((fill-paragraph-function - (cl-cadadr (assq 'fill-paragraph-function org-fb-vars))) - (fill-prefix (cl-cadadr (assq 'fill-prefix org-fb-vars))) - (paragraph-start (cl-cadadr (assq 'paragraph-start org-fb-vars))) - (paragraph-separate - (cl-cadadr (assq 'paragraph-separate org-fb-vars)))) - (fill-paragraph nil))) - ((and region transient-mark-mode mark-active - (not (eq (region-beginning) (region-end)))) - (let ((origin (point-marker)) - (start (region-beginning))) - (unwind-protect - (progn - (goto-char (region-end)) - (while (> (point) start) - (org-backward-paragraph) - (org-fill-element justify))) - (goto-char origin) - (set-marker origin nil)))) - (t (org-fill-element justify)))) -(org-remap org-mode-map 'fill-paragraph 'org-fill-paragraph) + (list (when current-prefix-arg 'full) t))) + (let ((hash (and (not (buffer-modified-p)) + (org-buffer-hash)))) + (cond + ((and region transient-mark-mode mark-active + (not (eq (region-beginning) (region-end)))) + (let ((origin (point-marker)) + (start (region-beginning))) + (unwind-protect + (progn + (goto-char (region-end)) + (while (> (point) start) + (org-backward-paragraph) + (org-fill-element justify))) + (goto-char origin) + (set-marker origin nil)))) + (t (org-fill-element justify))) + ;; If we didn't change anything in the buffer (and the buffer was + ;; previously unmodified), then flip the modification status back + ;; to "unchanged". + (when (and hash (equal hash (org-buffer-hash))) + (set-buffer-modified-p nil)))) (defun org-auto-fill-function () "Auto-fill function." @@ -23204,7 +19793,7 @@ region only contains such lines." (catch 'zerop (while (< (point) end) (unless (looking-at-p "[ \t]*$") - (let ((ind (org-get-indentation))) + (let ((ind (current-indentation))) (setq min-ind (min min-ind ind)) (when (zerop ind) (throw 'zerop t)))) (forward-line))))) @@ -23238,7 +19827,69 @@ region only contains such lines." (forward-line))))))) (set-marker end nil)))) + +;;; Blocks + +(defun org-block-map (function &optional start end) + "Call FUNCTION at the head of all source blocks in the current buffer. +Optional arguments START and END can be used to limit the range." + (let ((start (or start (point-min))) + (end (or end (point-max)))) + (save-excursion + (goto-char start) + (while (and (< (point) end) (re-search-forward org-block-regexp end t)) + (save-excursion + (save-match-data + (goto-char (match-beginning 0)) + (funcall function))))))) + +(defun org-next-block (arg &optional backward block-regexp) + "Jump to the next block. + +With a prefix argument ARG, jump forward ARG many blocks. + +When BACKWARD is non-nil, jump to the previous block. + +When BLOCK-REGEXP is non-nil, use this regexp to find blocks. +Match data is set according to this regexp when the function +returns. + +Return point at beginning of the opening line of found block. +Throw an error if no block is found." + (interactive "p") + (let ((re (or block-regexp "^[ \t]*#\\+BEGIN")) + (case-fold-search t) + (search-fn (if backward #'re-search-backward #'re-search-forward)) + (count (or arg 1)) + (origin (point)) + last-element) + (if backward (beginning-of-line) (end-of-line)) + (while (and (> count 0) (funcall search-fn re nil t)) + (let ((element (save-excursion + (goto-char (match-beginning 0)) + (save-match-data (org-element-at-point))))) + (when (and (memq (org-element-type element) + '(center-block comment-block dynamic-block + example-block export-block quote-block + special-block src-block verse-block)) + (<= (match-beginning 0) + (org-element-property :post-affiliated element))) + (setq last-element element) + (cl-decf count)))) + (if (= count 0) + (prog1 (goto-char (org-element-property :post-affiliated last-element)) + (save-match-data (org-show-context))) + (goto-char origin) + (user-error "No %s code blocks" (if backward "previous" "further"))))) +(defun org-previous-block (arg &optional block-regexp) + "Jump to the previous block. +With a prefix argument ARG, jump backward ARG many source blocks. +When BLOCK-REGEXP is non-nil, use this regexp to find blocks." + (interactive "p") + (org-next-block arg t block-regexp)) + + ;;; Comments ;; Org comments syntax is quite complex. It requires the entire line @@ -23363,21 +20014,54 @@ strictly within a source block, use appropriate comment syntax." (forward-line))))))))) (defun org-comment-dwim (_arg) - "Call `comment-dwim' within a source edit buffer if needed." + "Call the comment command you mean. +Call `org-toggle-comment' if on a heading, otherwise call +`comment-dwim', within a source edit buffer if needed." (interactive "*P") - (if (org-in-src-block-p) - (org-babel-do-in-edit-buffer (call-interactively 'comment-dwim)) - (call-interactively 'comment-dwim))) + (cond ((org-at-heading-p) + (call-interactively #'org-toggle-comment)) + ((org-in-src-block-p) + (org-babel-do-in-edit-buffer (call-interactively #'comment-dwim))) + (t (call-interactively #'comment-dwim)))) ;;; Timestamps API -;; This section contains tools to operate on timestamp objects, as -;; returned by, e.g. `org-element-context'. +;; This section contains tools to operate on, or create, timestamp +;; objects, as returned by, e.g. `org-element-context'. -(defun org-timestamp--to-internal-time (timestamp &optional end) - "Encode TIMESTAMP object into Emacs internal time. -Use end of date range or time range when END is non-nil." +(defun org-timestamp-from-string (s) + "Convert Org timestamp S, as a string, into a timestamp object. +Return nil if S is not a valid timestamp string." + (when (org-string-nw-p s) + (with-temp-buffer + (save-excursion (insert s)) + (org-element-timestamp-parser)))) + +(defun org-timestamp-from-time (time &optional with-time inactive) + "Convert a time value into a timestamp object. + +TIME is an Emacs internal time representation, as returned, e.g., +by `current-time'. + +When optional argument WITH-TIME is non-nil, return a timestamp +object with a time part, i.e., with hours and minutes. + +Return an inactive timestamp if INACTIVE is non-nil. Otherwise, +return an active timestamp." + (pcase-let ((`(,_ ,minute ,hour ,day ,month ,year . ,_) (decode-time time))) + (org-element-create 'timestamp + (list :type (if inactive 'inactive 'active) + :year-start year + :month-start month + :day-start day + :hour-start (and with-time hour) + :minute-start (and with-time minute))))) + +(defun org-timestamp-to-time (timestamp &optional end) + "Convert TIMESTAMP object into an Emacs internal time value. +Use end of date range or time range when END is non-nil. +Otherwise, use its start." (apply #'encode-time 0 (mapcar (lambda (prop) (or (org-element-property prop timestamp) 0)) @@ -23398,11 +20082,10 @@ FORMAT is a format specifier to be passed to When optional argument END is non-nil, use end of date-range or time-range, if possible. -When optional argument UTC is non-nil, time will be expressed as +When optional argument UTC is non-nil, time is be expressed as Universal Time." - (format-time-string - format (org-timestamp--to-internal-time timestamp end) - (and utc t))) + (format-time-string format (org-timestamp-to-time timestamp end) + (and utc t))) (defun org-timestamp-split-range (timestamp &optional end) "Extract a TIMESTAMP object from a date or time range. @@ -23459,9 +20142,7 @@ it has a `diary' type." (org-timestamp-format timestamp fmt t)) (org-timestamp-format timestamp fmt (eq boundary 'end))))))) - - -;;; Other stuff. +;;; Other stuff (defvar reftex-docstruct-symbol) (defvar org--rds) @@ -23498,9 +20179,13 @@ package ox-bibtex by Taru Karttunen." (defun org-beginning-of-line (&optional n) "Go to the beginning of the current visible line. -If this is a headline, and `org-special-ctrl-a/e' is set, ignore -tags on the first attempt, and only move to after the tags when -the cursor is already beyond the end of the headline. +If this is a headline, and `org-special-ctrl-a/e' is not nil or +symbol `reversed', on the first attempt move to where the +headline text starts, and only move to beginning of line when the +cursor is already before the start of the text of the headline. + +If `org-special-ctrl-a/e' is symbol `reversed' then go to the +start of the text on the second attempt. With argument N not nil or 1, move forward N - 1 lines first." (interactive "^p") @@ -23557,9 +20242,13 @@ With argument N not nil or 1, move forward N - 1 lines first." (defun org-end-of-line (&optional n) "Go to the end of the line, but before ellipsis, if any. -If this is a headline, and `org-special-ctrl-a/e' is set, ignore -tags on the first attempt, and only move to after the tags when -the cursor is already beyond the end of the headline. +If this is a headline, and `org-special-ctrl-a/e' is not nil or +symbol `reversed', ignore tags on the first attempt, and only +move to after the tags when the cursor is already beyond the end +of the headline. + +If `org-special-ctrl-a/e' is symbol `reversed' then ignore tags +on the second attempt. With argument N not nil or 1, move forward N - 1 lines first." (interactive "^p") @@ -23613,9 +20302,6 @@ With argument N not nil or 1, move forward N - 1 lines first." (end-of-line)))) (t (end-of-line))))) -(define-key org-mode-map "\C-a" 'org-beginning-of-line) -(define-key org-mode-map "\C-e" 'org-end-of-line) - (defun org-backward-sentence (&optional _arg) "Go to beginning of sentence, or beginning of table field. This will call `backward-sentence' or `org-table-beginning-of-field', @@ -23666,9 +20352,6 @@ depending on context." (let ((sentence-end (concat (sentence-end) "\\|^\\*+ .*$"))) (call-interactively #'forward-sentence))))))) -(define-key org-mode-map "\M-a" 'org-backward-sentence) -(define-key org-mode-map "\M-e" 'org-forward-sentence) - (defun org-kill-line (&optional _arg) "Kill line, to tags or end of line." (interactive) @@ -23676,19 +20359,25 @@ depending on context." ((or (not org-special-ctrl-k) (bolp) (not (org-at-heading-p))) - (when (and (get-char-property (min (point-max) (point-at-eol)) 'invisible) + (when (and (get-char-property (line-end-position) 'invisible) org-ctrl-k-protect-subtree (or (eq org-ctrl-k-protect-subtree 'error) (not (y-or-n-p "Kill hidden subtree along with headline? ")))) - (user-error "C-k aborted as it would kill a hidden subtree")) + (user-error + (substitute-command-keys + "`\\[org-kill-line]' aborted as it would kill a hidden subtree"))) (call-interactively (if (bound-and-true-p visual-line-mode) 'kill-visual-line 'kill-line))) - ((looking-at ".*?\\S-\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)[ \t]*$") - (kill-region (point) (match-beginning 1)) - (org-set-tags nil t)) - (t (kill-region (point) (point-at-eol))))) - -(define-key org-mode-map "\C-k" 'org-kill-line) + ((org-match-line org-tag-line-re) + (let ((end (save-excursion + (goto-char (match-beginning 1)) + (skip-chars-backward " \t") + (point)))) + (if (<= end (point)) ;on tags part + (kill-region (point) (line-end-position)) + (kill-region (point) end))) + (org-align-tags)) + (t (kill-region (point) (line-end-position))))) (defun org-yank (&optional arg) "Yank. If the kill is a subtree, treat it specially. @@ -23757,7 +20446,7 @@ interactive command with similar behavior." (or (looking-at org-outline-regexp) (re-search-forward org-outline-regexp-bol end t)) (while (and (< (point) end) (looking-at org-outline-regexp)) - (outline-hide-subtree) + (org-flag-subtree t) (org-cycle-show-empty-lines 'folded) (condition-case nil (outline-forward-same-level 1) @@ -23792,25 +20481,6 @@ interactive command with similar behavior." (and (bolp) (looking-at-p org-outline-regexp) (<= (org-outline-level) level)))))))) -(define-key org-mode-map "\C-y" 'org-yank) - -(defun org-truely-invisible-p () - "Check if point is at a character currently not visible. -This version does not only check the character property, but also -`visible-mode'." - (unless (bound-and-true-p visible-mode) - (org-invisible-p))) - -(defun org-invisible-p2 () - "Check if point is at a character currently not visible. - -If the point is at EOL (and not at the beginning of a buffer too), -move it back by one char before doing this check." - (save-excursion - (when (and (eolp) (not (bobp))) - (backward-char 1)) - (org-invisible-p))) - (defun org-back-to-heading (&optional invisible-ok) "Call `outline-back-to-heading', but provide a better error message." (condition-case nil @@ -23820,11 +20490,13 @@ move it back by one char before doing this check." (defun org-before-first-heading-p () "Before first heading?" - (save-excursion - (end-of-line) - (null (re-search-backward org-outline-regexp-bol nil t)))) + (org-with-limited-levels + (save-excursion + (end-of-line) + (null (re-search-backward org-outline-regexp-bol nil t))))) -(defun org-at-heading-p (&optional ignored) +(defun org-at-heading-p (&optional _) + "Non-nil when on a headline." (outline-on-heading-p t)) (defun org-in-commented-heading-p (&optional no-inheritance) @@ -23843,20 +20515,20 @@ unless optional argument NO-INHERITANCE is non-nil." (save-excursion (and (org-up-heading-safe) (org-in-commented-heading-p)))))) (defun org-at-comment-p nil - "Is cursor in a commented line?" + "Return t if cursor is in a commented line." (save-excursion (save-match-data (beginning-of-line) (looking-at "^[ \t]*# ")))) (defun org-at-drawer-p nil - "Is cursor at a drawer keyword?" + "Return t if cursor is at a drawer keyword." (save-excursion (move-beginning-of-line 1) (looking-at org-drawer-regexp))) (defun org-at-block-p nil - "Is cursor at a block keyword?" + "Return t if cursor is at a block keyword." (save-excursion (move-beginning-of-line 1) (looking-at org-block-regexp))) @@ -23876,12 +20548,6 @@ empty." (defun org-at-heading-or-item-p () (or (org-at-heading-p) (org-at-item-p))) -(defun org-at-target-p () - (or (org-in-regexp org-radio-target-regexp) - (org-in-regexp org-target-regexp))) -;; Compatibility alias with Org versions < 7.8.03 -(defalias 'org-on-target-p 'org-at-target-p) - (defun org-up-heading-all (arg) "Move to the heading line of which the present line is a subheading. This function considers both visible and invisible heading lines. @@ -23967,15 +20633,13 @@ When ENTRY is non-nil, show the entire entry." (save-excursion (org-back-to-heading t) ;; Check if we should show the entire entry - (if entry - (progn - (org-show-entry) - (save-excursion - (and (outline-next-heading) - (org-flag-heading nil)))) - (outline-flag-region (max (point-min) (1- (point))) - (save-excursion (outline-end-of-heading) (point)) - flag)))) + (if (not entry) + (org-flag-region + (line-end-position 0) (line-end-position) flag 'outline) + (org-show-entry) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil)))))) (defun org-get-next-sibling () "Move to next heading of the same level, and return point. @@ -24112,52 +20776,6 @@ respect customization of `org-odd-levels-only'." (org-with-limited-levels (outline-previous-visible-heading arg))) -(defun org-next-block (arg &optional backward block-regexp) - "Jump to the next block. - -With a prefix argument ARG, jump forward ARG many blocks. - -When BACKWARD is non-nil, jump to the previous block. - -When BLOCK-REGEXP is non-nil, use this regexp to find blocks. -Match data is set according to this regexp when the function -returns. - -Return point at beginning of the opening line of found block. -Throw an error if no block is found." - (interactive "p") - (let ((re (or block-regexp "^[ \t]*#\\+BEGIN")) - (case-fold-search t) - (search-fn (if backward #'re-search-backward #'re-search-forward)) - (count (or arg 1)) - (origin (point)) - last-element) - (if backward (beginning-of-line) (end-of-line)) - (while (and (> count 0) (funcall search-fn re nil t)) - (let ((element (save-excursion - (goto-char (match-beginning 0)) - (save-match-data (org-element-at-point))))) - (when (and (memq (org-element-type element) - '(center-block comment-block dynamic-block - example-block export-block quote-block - special-block src-block verse-block)) - (<= (match-beginning 0) - (org-element-property :post-affiliated element))) - (setq last-element element) - (cl-decf count)))) - (if (= count 0) - (prog1 (goto-char (org-element-property :post-affiliated last-element)) - (save-match-data (org-show-context))) - (goto-char origin) - (user-error "No %s code blocks" (if backward "previous" "further"))))) - -(defun org-previous-block (arg &optional block-regexp) - "Jump to the previous block. -With a prefix argument ARG, jump backward ARG many source blocks. -When BLOCK-REGEXP is non-nil, use this regexp to find blocks." - (interactive "p") - (org-next-block arg t block-regexp)) - (defun org-forward-paragraph () "Move forward to beginning of next paragraph or equivalent. @@ -24543,72 +21161,6 @@ modified." (org-do-remove-indentation)))))))) (funcall unindent-tree (org-element-contents parse-tree)))) -(defun org-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." - (interactive "p") - ;; If `orgstruct-mode' is active, use the slower version. - (if orgstruct-mode (call-interactively #'outline-show-children) - (save-excursion - (org-back-to-heading t) - (let* ((current-level (funcall outline-level)) - (max-level (org-get-valid-level - current-level - (if level (prefix-numeric-value level) 1))) - (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 - (cond - ((not (featurep 'org-inlinetask)) "") - (org-odd-levels-only (- (* 2 org-inlinetask-min-level) - 3)) - (t (1- org-inlinetask-min-level)))))) - ;; Display parent heading. - (outline-flag-region (line-end-position 0) (line-end-position) nil) - (forward-line) - ;; Display children. First child may be deeper than expected - ;; 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)) - (outline-flag-region - (line-end-position 0) (line-end-position) nil)))))) - -(defun org-show-subtree () - "Show everything after this heading at deeper levels." - (interactive) - (outline-flag-region - (point) - (save-excursion - (org-end-of-subtree t t)) - nil)) - -(defun org-show-entry () - "Show the body directly following this heading. -Show the heading too, if it is currently invisible." - (interactive) - (save-excursion - (ignore-errors - (org-back-to-heading t) - (outline-flag-region - (max (point-min) (1- (point))) - (save-excursion - (if (re-search-forward - (concat "[\r\n]\\(" org-outline-regexp "\\)") nil t) - (match-beginning 1) - (point-max))) - nil) - (org-cycle-hide-drawers 'children)))) - (defun org-make-options-regexp (kwds &optional extra) "Make a regular expression for keyword lines. KWDS is a list of keywords, as strings. Optional argument EXTRA, @@ -24618,285 +21170,61 @@ when non-nil, is a regexp matching keywords names." (and extra (concat (and kwds "\\|") extra)) "\\):[ \t]*\\(.*\\)")) -;;;; Integration with and fixes for other packages - -;;; Imenu support + +;;; Conveniently switch to Info nodes -(defvar-local org-imenu-markers nil - "All markers currently used by Imenu.") +(defun org-info-find-node (&optional nodename) + "Find Info documentation NODENAME or Org documentation according context. +Started from `gnus-info-find-node'." + (interactive) + (Info-goto-node + (or nodename + (let ((default-org-info-node "(org) Top")) + (cond + ((eq 'org-agenda-mode major-mode) "(org) Agenda Views") + ((eq 'org-mode major-mode) + (let* ((context (org-element-at-point)) + (element-info-nodes ; compare to `org-element-all-elements'. + `((babel-call . "(org) Evaluating Code Blocks") + (center-block . "(org) Paragraphs") + (clock . ,default-org-info-node) + (comment . "(org) Comment Lines") + (comment-block . "(org) Comment Lines") + (diary-sexp . ,default-org-info-node) + (drawer . "(org) Drawers") + (dynamic-block . "(org) Dynamic Blocks") + (example-block . "(org) Literal Examples") + (export-block . "(org) ASCII/Latin-1/UTF-8 export") + (fixed-width . ,default-org-info-node) + (footnote-definition . "(org) Creating Footnotes") + (headline . "(org) Document Structure") + (horizontal-rule . "(org) Built-in Table Editor") + (inlinetask . ,default-org-info-node) + (item . "(org) Plain Lists") + (keyword . "(org) Per-file keywords") + (latex-environment . "(org) LaTeX Export") + (node-property . "(org) Properties and Columns") + (paragraph . "(org) Paragraphs") + (plain-list . "(org) Plain Lists") + (planning . "(org) Deadlines and Scheduling") + (property-drawer . "(org) Properties and Columns") + (quote-block . "(org) Paragraphs") + (section . ,default-org-info-node) + (special-block . ,default-org-info-node) + (src-block . "(org) Working with Source Code") + (table . "(org) Tables") + (table-row . "(org) Tables") + (verse-block . "(org) Paragraphs")))) + (or (cdr (assoc (car context) element-info-nodes)) + default-org-info-node))) + (t default-org-info-node)))))) -(defun org-imenu-new-marker (&optional pos) - "Return a new marker for use by Imenu, and remember the marker." - (let ((m (make-marker))) - (move-marker m (or pos (point))) - (push m org-imenu-markers) - m)) + +;;; Finish up -(defun org-imenu-get-tree () - "Produce the index for Imenu." - (dolist (x org-imenu-markers) (move-marker x nil)) - (setq org-imenu-markers nil) - (let* ((case-fold-search nil) - (n org-imenu-depth) - (re (concat "^" (org-get-limited-outline-regexp))) - (subs (make-vector (1+ n) nil)) - (last-level 0) - m level head0 head) - (org-with-wide-buffer - (goto-char (point-max)) - (while (re-search-backward re nil t) - (setq level (org-reduced-level (funcall outline-level))) - (when (and (<= level n) - (looking-at org-complex-heading-regexp) - (setq head0 (match-string-no-properties 4))) - (setq head (org-link-display-format head0) - m (org-imenu-new-marker)) - (org-add-props head nil 'org-imenu-marker m 'org-imenu t) - (if (>= level last-level) - (push (cons head m) (aref subs level)) - (push (cons head (aref subs (1+ level))) (aref subs level)) - (cl-loop for i from (1+ level) to n do (aset subs i nil))) - (setq last-level level)))) - (aref subs 1))) - -(eval-after-load "imenu" - '(progn - (add-hook 'imenu-after-jump-hook - (lambda () - (when (derived-mode-p 'org-mode) - (org-show-context 'org-goto)))))) - -(defun org-link-display-format (s) - "Replace links in string S with their description. -If there is no description, use the link target." - (save-match-data - (replace-regexp-in-string - org-bracket-link-analytic-regexp - (lambda (m) - (if (match-end 5) (match-string 5 m) - (concat (match-string 1 m) (match-string 3 m)))) - s nil t))) - -(defun org-toggle-link-display () - "Toggle the literal or descriptive display of links." - (interactive) - (if org-descriptive-links - (progn (org-remove-from-invisibility-spec '(org-link)) - (org-restart-font-lock) - (setq org-descriptive-links nil)) - (progn (add-to-invisibility-spec '(org-link)) - (org-restart-font-lock) - (setq org-descriptive-links t)))) - -;; Speedbar support - -(defvar org-speedbar-restriction-lock-overlay (make-overlay 1 1) - "Overlay marking the agenda restriction line in speedbar.") -(overlay-put org-speedbar-restriction-lock-overlay - 'face 'org-agenda-restriction-lock) -(overlay-put org-speedbar-restriction-lock-overlay - 'help-echo "Agendas are currently limited to this item.") -(delete-overlay org-speedbar-restriction-lock-overlay) - -(defun org-speedbar-set-agenda-restriction () - "Restrict future agenda commands to the location at point in speedbar. -To get rid of the restriction, use `\\[org-agenda-remove-restriction-lock]'." - (interactive) - (require 'org-agenda) - (let (p m tp np dir txt) - (cond - ((setq p (text-property-any (point-at-bol) (point-at-eol) - 'org-imenu t)) - (setq m (get-text-property p 'org-imenu-marker)) - (with-current-buffer (marker-buffer m) - (goto-char m) - (org-agenda-set-restriction-lock 'subtree))) - ((setq p (text-property-any (point-at-bol) (point-at-eol) - 'speedbar-function 'speedbar-find-file)) - (setq tp (previous-single-property-change - (1+ p) 'speedbar-function) - np (next-single-property-change - tp 'speedbar-function) - dir (speedbar-line-directory) - txt (buffer-substring-no-properties (or tp (point-min)) - (or np (point-max)))) - (with-current-buffer (find-file-noselect - (let ((default-directory dir)) - (expand-file-name txt))) - (unless (derived-mode-p 'org-mode) - (user-error "Cannot restrict to non-Org mode file")) - (org-agenda-set-restriction-lock 'file))) - (t (user-error "Don't know how to restrict Org mode agenda"))) - (move-overlay org-speedbar-restriction-lock-overlay - (point-at-bol) (point-at-eol)) - (setq current-prefix-arg nil) - (org-agenda-maybe-redo))) - -(defvar speedbar-file-key-map) -(declare-function speedbar-add-supported-extension "speedbar" (extension)) -(eval-after-load "speedbar" - '(progn - (speedbar-add-supported-extension ".org") - (define-key speedbar-file-key-map "<" 'org-speedbar-set-agenda-restriction) - (define-key speedbar-file-key-map "\C-c\C-x<" 'org-speedbar-set-agenda-restriction) - (define-key speedbar-file-key-map ">" 'org-agenda-remove-restriction-lock) - (define-key speedbar-file-key-map "\C-c\C-x>" 'org-agenda-remove-restriction-lock) - (add-hook 'speedbar-visiting-tag-hook - (lambda () (and (derived-mode-p 'org-mode) (org-show-context 'org-goto)))))) - -;;; Fixes and Hacks for problems with other packages - -(defun org--flyspell-object-check-p (element) - "Non-nil when Flyspell can check object at point. -ELEMENT is the element at point." - (let ((object (save-excursion - (when (looking-at-p "\\>") (backward-char)) - (org-element-context element)))) - (cl-case (org-element-type object) - ;; Prevent checks in links due to keybinding conflict with - ;; Flyspell. - ((code entity export-snippet inline-babel-call - inline-src-block line-break latex-fragment link macro - statistics-cookie target timestamp verbatim) - nil) - (footnote-reference - ;; Only in inline footnotes, within the definition. - (and (eq (org-element-property :type object) 'inline) - (< (save-excursion - (goto-char (org-element-property :begin object)) - (search-forward ":" nil t 2)) - (point)))) - (otherwise t)))) - -(defun org-mode-flyspell-verify () - "Function used for `flyspell-generic-check-word-predicate'." - (if (org-at-heading-p) - ;; At a headline or an inlinetask, check title only. This is - ;; faster than relying on `org-element-at-point'. - (and (save-excursion (beginning-of-line) - (and (let ((case-fold-search t)) - (not (looking-at-p "\\*+ END[ \t]*$"))) - (let ((case-fold-search nil)) - (looking-at org-complex-heading-regexp)))) - (match-beginning 4) - (>= (point) (match-beginning 4)) - (or (not (match-beginning 5)) - (< (point) (match-beginning 5)))) - (let* ((element (org-element-at-point)) - (post-affiliated (org-element-property :post-affiliated element))) - (cond - ;; Ignore checks in all affiliated keywords but captions. - ((< (point) post-affiliated) - (and (save-excursion - (beginning-of-line) - (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)))) - (and drawer - (eq (compare-strings - log nil nil - (org-element-property :drawer-name drawer) nil nil t) - t))))) - nil) - (t - (cl-case (org-element-type element) - ((comment quote-section) t) - (comment-block - ;; Allow checks between block markers, not on them. - (and (> (line-beginning-position) post-affiliated) - (save-excursion - (end-of-line) - (skip-chars-forward " \r\t\n") - (< (point) (org-element-property :end element))))) - ;; Arbitrary list of keywords where checks are meaningful. - ;; Make sure point is on the value part of the element. - (keyword - (and (member (org-element-property :key element) - '("DESCRIPTION" "TITLE")) - (save-excursion - (search-backward ":" (line-beginning-position) t)))) - ;; Check is globally allowed in paragraphs verse blocks and - ;; 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))) - (and cbeg (>= (point) cbeg) (< (point) cend) - (org--flyspell-object-check-p element)))))))))) -(put 'org-mode 'flyspell-mode-predicate 'org-mode-flyspell-verify) - -(defun org-remove-flyspell-overlays-in (beg end) - "Remove flyspell overlays in region." - (and (bound-and-true-p flyspell-mode) - (fboundp 'flyspell-delete-region-overlays) - (flyspell-delete-region-overlays beg end))) - -(defvar flyspell-delayed-commands) -(eval-after-load "flyspell" - '(add-to-list 'flyspell-delayed-commands 'org-self-insert-command)) - -;; Make `bookmark-jump' shows the jump location if it was hidden. -(eval-after-load "bookmark" - '(if (boundp 'bookmark-after-jump-hook) - ;; We can use the hook - (add-hook 'bookmark-after-jump-hook 'org-bookmark-jump-unhide) - ;; Hook not available, use advice - (defadvice bookmark-jump (after org-make-visible activate) - "Make the position visible." - (org-bookmark-jump-unhide)))) - -;; Make sure saveplace shows the location if it was hidden -(eval-after-load "saveplace" - '(defadvice save-place-find-file-hook (after org-make-visible activate) - "Make the position visible." - (org-bookmark-jump-unhide))) - -;; Make sure ecb shows the location if it was hidden -(eval-after-load "ecb" - '(defadvice ecb-method-clicked (after esf/org-show-context activate) - "Make hierarchy visible when jumping into location from ECB tree buffer." - (when (derived-mode-p 'org-mode) - (org-show-context)))) - -(defun org-bookmark-jump-unhide () - "Unhide the current position, to show the bookmark location." - (and (derived-mode-p 'org-mode) - (or (org-invisible-p) - (save-excursion (goto-char (max (point-min) (1- (point)))) - (org-invisible-p))) - (org-show-context 'bookmark-jump))) - -(defun org-mark-jump-unhide () - "Make the point visible with `org-show-context' after jumping to the mark." - (when (and (derived-mode-p 'org-mode) - (org-invisible-p)) - (org-show-context 'mark-goto))) - -(eval-after-load "simple" - '(defadvice pop-to-mark-command (after org-make-visible activate) - "Make the point visible with `org-show-context'." - (org-mark-jump-unhide))) - -(eval-after-load "simple" - '(defadvice exchange-point-and-mark (after org-make-visible activate) - "Make the point visible with `org-show-context'." - (org-mark-jump-unhide))) - -(eval-after-load "simple" - '(defadvice pop-global-mark (after org-make-visible activate) - "Make the point visible with `org-show-context'." - (org-mark-jump-unhide))) - -;; Make session.el ignore our circular variable -(defvar session-globals-exclude) -(eval-after-load "session" - '(add-to-list 'session-globals-exclude 'org-mark-ring)) - -;;;; Finish up +(add-hook 'org-mode-hook ;remove overlays when changing major mode + (lambda () (add-hook 'change-major-mode-hook + 'org-show-all 'append 'local))) (provide 'org) diff --git a/lisp/org/ox-ascii.el b/lisp/org/ox-ascii.el index 7c9920f64c5..6e6c17c4964 100644 --- a/lisp/org/ox-ascii.el +++ b/lisp/org/ox-ascii.el @@ -632,7 +632,7 @@ Return value is a symbol among `left', `center', `right' and (or justification 'left))) (defun org-ascii--build-title - (element info text-width &optional underline notags toc) + (element info text-width &optional underline notags toc) "Format ELEMENT title and return it. ELEMENT is either an `headline' or `inlinetask' element. INFO is @@ -651,13 +651,12 @@ possible. It doesn't apply to `inlinetask' elements." (let* ((headlinep (eq (org-element-type element) 'headline)) (numbers ;; Numbering is specific to headlines. - (and headlinep (org-export-numbered-headline-p element info) - ;; All tests passed: build numbering string. - (concat - (mapconcat - 'number-to-string - (org-export-get-headline-number element info) ".") - " "))) + (and headlinep + (org-export-numbered-headline-p element info) + (let ((numbering (org-export-get-headline-number element info))) + (if toc (format "%d. " (org-last numbering)) + (concat (mapconcat #'number-to-string numbering ".") + " "))))) (text (org-trim (org-export-data @@ -672,8 +671,7 @@ possible. It doesn't apply to `inlinetask' elements." (plist-get info :with-tags) (let ((tag-list (org-export-get-tags element info))) (and tag-list - (format ":%s:" - (mapconcat 'identity tag-list ":")))))) + (org-make-tag-string tag-list))))) (priority (and (plist-get info :with-priority) (let ((char (org-element-property :priority element))) @@ -733,7 +731,7 @@ caption keyword." (org-export-data caption info)) (org-ascii--current-text-width element info) info))))) -(defun org-ascii--build-toc (info &optional n keyword local) +(defun org-ascii--build-toc (info &optional n keyword scope) "Return a table of contents. INFO is a plist used as a communication channel. @@ -744,10 +742,10 @@ depth of the table. Optional argument KEYWORD specifies the TOC keyword, if any, from which the table of contents generation has been initiated. -When optional argument LOCAL is non-nil, build a table of -contents according to the current headline." +When optional argument SCOPE is non-nil, build a table of +contents according to the specified scope." (concat - (unless local + (unless scope (let ((title (org-ascii--translate "Table of Contents" info))) (concat title "\n" (make-string @@ -769,7 +767,7 @@ contents according to the current headline." (or (not (plist-get info :with-tags)) (eq (plist-get info :with-tags) 'not-in-toc)) 'toc)))) - (org-export-collect-headlines info n (and local keyword)) "\n")))) + (org-export-collect-headlines info n scope) "\n")))) (defun org-ascii--list-listings (keyword info) "Return a list of listings. @@ -960,7 +958,7 @@ channel." (t (concat (org-ascii--fill-string - (format "[%s] %s" anchor (org-element-property :raw-link link)) + (format "[%s] <%s>" anchor (org-element-property :raw-link link)) width info) "\n\n"))))) links "")) @@ -1518,8 +1516,13 @@ information." ((string-match-p "\\<headlines\\>" value) (let ((depth (and (string-match "\\<[0-9]+\\>" value) (string-to-number (match-string 0 value)))) - (localp (string-match-p "\\<local\\>" value))) - (org-ascii--build-toc info depth keyword localp))) + (scope + (cond + ((string-match ":target +\\(\".+?\"\\|\\S-+\\)" value) ;link + (org-export-resolve-link + (org-strip-quotes (match-string 1 value)) info)) + ((string-match-p "\\<local\\>" value) keyword)))) ;local + (org-ascii--build-toc info depth keyword scope))) ((string-match-p "\\<tables\\>" value) (org-ascii--list-tables keyword info)) ((string-match-p "\\<listings\\>" value) @@ -1602,11 +1605,13 @@ INFO is a plist holding contextual information." ;; Don't know what to do. Signal it. (_ "???")))) (t - (let ((raw-link (org-element-property :raw-link link))) - (if (not (org-string-nw-p desc)) (format "[%s]" raw-link) + (let ((raw-link (concat (org-element-property :type link) + ":" + (org-element-property :path link)))) + (if (not (org-string-nw-p desc)) (format "<%s>" raw-link) (concat (format "[%s]" desc) (and (not (plist-get info :ascii-links-to-notes)) - (format " (%s)" raw-link))))))))) + (format " (<%s>)" raw-link))))))))) ;;;; Node Properties @@ -2067,6 +2072,20 @@ a communication channel." ;;; End-user functions ;;;###autoload +(defun org-ascii-convert-region-to-ascii () + "Assume region has Org syntax, and convert it to plain ASCII." + (interactive) + (let ((org-ascii-charset 'ascii)) + (org-export-replace-region-by 'ascii))) + +;;;###autoload +(defun org-ascii-convert-region-to-utf8 () + "Assume region has Org syntax, and convert it to UTF-8." + (interactive) + (let ((org-ascii-charset 'utf-8)) + (org-export-replace-region-by 'ascii))) + +;;;###autoload (defun org-ascii-export-as-ascii (&optional async subtreep visible-only body-only ext-plist) "Export current buffer to a text buffer. diff --git a/lisp/org/ox-beamer.el b/lisp/org/ox-beamer.el index 77c1b33c5d9..0de5e47dacb 100644 --- a/lisp/org/ox-beamer.el +++ b/lisp/org/ox-beamer.el @@ -424,9 +424,8 @@ used as a communication channel." (let* ((beamer-opt (org-element-property :BEAMER_OPT headline)) (options ;; Collect nonempty options from default value and - ;; headline's properties. Also add a label for - ;; links. - (cl-remove-if-not 'org-string-nw-p + ;; headline's properties. + (cl-remove-if-not #'org-string-nw-p (append (org-split-string (plist-get info :beamer-frame-default-options) ",") @@ -436,29 +435,31 @@ used as a communication channel." ;; them. (and (string-match "^\\[?\\(.*\\)\\]?$" beamer-opt) (match-string 1 beamer-opt)) - ",")) - ;; Provide an automatic label for the frame - ;; unless the user specified one. Also refrain - ;; from labeling `allowframebreaks' frames; this - ;; is not allowed by beamer. - (unless (and beamer-opt - (or (string-match "\\(^\\|,\\)label=" beamer-opt) - (string-match "allowframebreaks" beamer-opt))) - (list - (let ((label (org-beamer--get-label headline info))) - ;; Labels containing colons need to be - ;; wrapped within braces. - (format (if (string-match-p ":" label) - "label={%s}" - "label=%s") - label)))))))) + ","))))) + (fragile + ;; Add "fragile" option if necessary. + (and fragilep + (not (member "fragile" options)) + (list "fragile"))) + (label + ;; Provide an automatic label for the frame unless + ;; the user specified one. Also refrain from + ;; labeling `allowframebreaks' frames; this is not + ;; allowed by Beamer. + (and (not (member "allowframebreaks" options)) + (not (cl-some (lambda (s) (string-match-p "^label=" s)) + options)) + (list + (let ((label (org-beamer--get-label headline info))) + ;; Labels containing colons need to be + ;; wrapped within braces. + (format (if (string-match-p ":" label) + "label={%s}" + "label=%s") + label)))))) ;; Change options list into a string. (org-beamer--normalize-argument - (mapconcat - 'identity - (if (or (not fragilep) (member "fragile" options)) options - (cons "fragile" options)) - ",") + (mapconcat #'identity (append label fragile options) ",") 'option)) ;; Title. (let ((env (org-element-property :BEAMER_ENV headline))) @@ -644,13 +645,22 @@ as a communication channel." contents)) ;; Case 4: HEADLINE is a note. ((member environment '("note" "noteNH")) - (format "\\note{%s}" - (concat (and (equal environment "note") - (concat - (org-export-data - (org-element-property :title headline) info) - "\n")) - (org-trim contents)))) + (concat "\\note" + ;; Overlay specification. + (let ((overlay (org-element-property :BEAMER_ACT headline))) + (when overlay + (org-beamer--normalize-argument + overlay + (if (string-match "\\`\\[.*\\]\\'" overlay) + 'defaction 'action)))) + (format "{%s}" + (concat (and (equal environment "note") + (concat + (org-export-data + (org-element-property :title headline) + info) + "\n")) + (org-trim contents))))) ;; Case 5: HEADLINE is a frame. ((= level frame-level) (org-beamer--format-frame headline contents info)) @@ -914,9 +924,9 @@ value." (org-back-to-heading t) ;; Filter out Beamer-related tags and install environment tag. (let ((tags (cl-remove-if (lambda (x) (string-match "^B_" x)) - (org-get-tags))) + (org-get-tags nil t))) (env-tag (and (org-string-nw-p value) (concat "B_" value)))) - (org-set-tags-to (if env-tag (cons env-tag tags) tags)) + (org-set-tags (if env-tag (cons env-tag tags) tags)) (when env-tag (org-toggle-tag env-tag 'on))))) ((equal property "BEAMER_col") (org-toggle-tag "BMCOL" (if (org-string-nw-p value) 'on 'off))))) @@ -1075,12 +1085,12 @@ aid, but the tag does not have any semantic meaning." (org-tag-persistent-alist nil) (org-use-fast-tag-selection t) (org-fast-tag-selection-single-key t)) - (org-set-tags) - (let ((tags (or (ignore-errors (org-get-tags-string)) ""))) + (org-set-tags-command) + (let ((tags (org-get-tags nil t))) (cond ;; For a column, automatically ask for its width. ((eq org-last-tag-selection-key ?|) - (if (string-match ":BMCOL:" tags) + (if (member "BMCOL" tags) (org-set-property "BEAMER_col" (read-string "Column width: ")) (org-delete-property "BEAMER_col"))) ;; For an "againframe" section, automatically ask for reference @@ -1096,8 +1106,12 @@ aid, but the tag does not have any semantic meaning." (read-string "Frame reference (*Title, #custom-id, id:...): ")) (org-set-property "BEAMER_act" (read-string "Overlay specification: ")))) - ((string-match (concat ":B_\\(" (mapconcat 'car envs "\\|") "\\):") tags) - (org-entry-put nil "BEAMER_env" (match-string 1 tags))) + ((let* ((tags-re (concat "B_" (regexp-opt (mapcar #'car envs) t))) + (env (cl-some (lambda (tag) + (and (string-match tags-re tag) + (match-string 1 tag))) + tags))) + (and env (progn (org-entry-put nil "BEAMER_env" env) t)))) (t (org-entry-delete nil "BEAMER_env")))))) ;;;###autoload diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index 8445f236bae..83d0fd2e9c5 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -152,6 +152,7 @@ (:html-metadata-timestamp-format nil nil org-html-metadata-timestamp-format) (:html-postamble-format nil nil org-html-postamble-format) (:html-preamble-format nil nil org-html-preamble-format) + (:html-self-link-headlines nil nil org-html-self-link-headlines) (:html-table-align-individual-fields nil nil org-html-table-align-individual-fields) (:html-table-caption-above nil nil org-html-table-caption-above) @@ -171,6 +172,7 @@ (:html-table-row-open-tag nil nil org-html-table-row-open-tag) (:html-table-row-close-tag nil nil org-html-table-row-close-tag) (:html-xml-declaration nil nil org-html-xml-declaration) + (:html-wrap-src-lines nil nil org-html-wrap-src-lines) (:html-klipsify-src nil nil org-html-klipsify-src) (:html-klipse-css nil nil org-html-klipse-css) (:html-klipse-js nil nil org-html-klipse-js) @@ -215,7 +217,7 @@ (defconst org-html-html5-elements '("article" "aside" "audio" "canvas" "details" "figcaption" "figure" "footer" "header" "menu" "meter" "nav" "output" - "progress" "section" "video") + "progress" "section" "summary" "video") "New elements in html5. For blocks that should contain headlines, use the HTML_CONTAINER @@ -430,6 +432,19 @@ for the JavaScript code in this tag. .footdef { margin-bottom: 1em; } .figure { padding: 1em; } .figure p { text-align: center; } + .equation-container { + display: table; + text-align: center; + width: 100%; + } + .equation { + vertical-align: middle; + } + .equation-label { + display: table-cell; + text-align: right; + vertical-align: middle; + } .inlinetask { padding: 10px; border: 2px solid gray; @@ -789,6 +804,13 @@ but without \"name\" attribute." :package-version '(Org . "8.0") :type 'boolean) +(defcustom org-html-self-link-headlines nil + "When non-nil, the headlines contain a hyperlink to themselves." + :group 'org-export-html + :package-version '(Org . "9.3") + :type 'boolean + :safe #'booleanp) + ;;;; Inlinetasks (defcustom org-html-format-inlinetask-function @@ -863,6 +885,7 @@ link to the image." (defcustom org-html-inline-image-rules '(("file" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\|svg\\)\\'") + ("attachment" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\|svg\\)\\'") ("http" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\|svg\\)\\'") ("https" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\|svg\\)\\'")) "Rules characterizing image files that can be inlined into HTML. @@ -910,6 +933,15 @@ in all modes you want. Then, use the command :group 'org-export-html :type 'string) +(defcustom org-html-wrap-src-lines nil + "If non-nil, wrap individual lines of source blocks in \"code\" elements. +In this case, add line number in attribute \"data-ox-html-linenr\" when line +numbers are enabled." + :group 'org-export-html + :package-version '(Org . "9.3") + :type 'boolean + :safe t) + ;;;; Table (defcustom org-html-table-default-attributes @@ -1693,7 +1725,7 @@ object unless a different class is specified with an attribute." (defun org-html--textarea-block (element) "Transcode ELEMENT into a textarea block. -ELEMENT is either a src block or an example block." +ELEMENT is either a source or an example block." (let* ((code (car (org-export-unravel-code element))) (attr (org-export-read-attribute :attr_html element))) (format "<p>\n<textarea cols=\"%s\" rows=\"%s\">\n%s</textarea>\n</p>" @@ -1736,8 +1768,8 @@ If you then set `org-html-htmlize-output-type' to `css', calls to the function `org-html-htmlize-region-for-paste' will produce code that uses these same face definitions." (interactive) - (or (require 'htmlize nil t) - (error "Please install htmlize from https://github.com/hniksic/emacs-htmlize")) + (unless (require 'htmlize nil t) + (error "htmlize library missing. Aborting")) (and (get-buffer "*html*") (kill-buffer "*html*")) (with-temp-buffer (let ((fl (face-list)) @@ -1751,12 +1783,12 @@ produce code that uses these same face definitions." (htmlize-region (point-min) (point-max)))) (pop-to-buffer-same-window "*html*") (goto-char (point-min)) - (if (re-search-forward "<style" nil t) - (delete-region (point-min) (match-beginning 0))) - (if (re-search-forward "</style>" nil t) - (delete-region (1+ (match-end 0)) (point-max))) + (when (re-search-forward "<style" nil t) + (delete-region (point-min) (match-beginning 0))) + (when (re-search-forward "</style>" nil t) + (delete-region (1+ (match-end 0)) (point-max))) (beginning-of-line 1) - (if (looking-at " +") (replace-match "")) + (when (looking-at " +") (replace-match "")) (goto-char (point-min))) (defun org-html--make-string (n string) @@ -1771,33 +1803,38 @@ Replaces invalid characters with \"_\"." (defun org-html-footnote-section (info) "Format the footnote section. INFO is a plist used as a communication channel." - (let* ((fn-alist (org-export-collect-footnote-definitions info)) - (fn-alist - (cl-loop for (n _type raw) in fn-alist collect - (cons n (if (eq (org-element-type raw) 'org-data) - (org-trim (org-export-data raw info)) - (format "<div class=\"footpara\">%s</div>" - (org-trim (org-export-data raw info)))))))) - (when fn-alist + (pcase (org-export-collect-footnote-definitions info) + (`nil nil) + (definitions (format (plist-get info :html-footnotes-section) (org-html--translate "Footnotes" info) (format "\n%s\n" (mapconcat - (lambda (fn) - (let ((n (car fn)) (def (cdr fn))) - (format - "<div class=\"footdef\">%s %s</div>\n" - (format - (plist-get info :html-footnote-format) - (org-html--anchor - (format "fn.%d" n) - n - (format " class=\"footnum\" href=\"#fnr.%d\"" n) - info)) - def))) - fn-alist + (lambda (definition) + (pcase definition + (`(,n ,_ ,def) + ;; `org-export-collect-footnote-definitions' can return + ;; two kinds of footnote definitions: inline and blocks. + ;; Since this should not make any difference in the HTML + ;; output, we wrap the inline definitions within + ;; a "footpara" class paragraph. + (let ((inline? (not (org-element-map def org-element-all-elements + #'identity nil t))) + (anchor (org-html--anchor + (format "fn.%d" n) + n + (format " class=\"footnum\" href=\"#fnr.%d\"" n) + info)) + (contents (org-trim (org-export-data def info)))) + (format "<div class=\"footdef\">%s %s</div>\n" + (format (plist-get info :html-footnote-format) anchor) + (format "<div class=\"footpara\">%s</div>" + (if (not inline?) contents + (format "<p class=\"footpara\">%s</p>" + contents)))))))) + definitions "\n")))))) @@ -1957,44 +1994,42 @@ communication channel." (creator (cdr (assq ?c spec))) (validation-link (cdr (assq ?v spec)))) (concat - (when (and (plist-get info :with-date) - (org-string-nw-p date)) - (format "<p class=\"date\">%s: %s</p>\n" - (org-html--translate "Date" info) - date)) - (when (and (plist-get info :with-author) - (org-string-nw-p author)) - (format "<p class=\"author\">%s: %s</p>\n" - (org-html--translate "Author" info) - author)) - (when (and (plist-get info :with-email) - (org-string-nw-p email)) - (format "<p class=\"email\">%s: %s</p>\n" - (org-html--translate "Email" info) - email)) - (when (plist-get info :time-stamp-file) - (format - "<p class=\"date\">%s: %s</p>\n" - (org-html--translate "Created" info) - (format-time-string - (plist-get info :html-metadata-timestamp-format)))) - (when (plist-get info :with-creator) - (format "<p class=\"creator\">%s</p>\n" creator)) - (format "<p class=\"validation\">%s</p>\n" - validation-link)))) - (t (format-spec - (or (cadr (assoc-string - (plist-get info :language) - (eval (intern - (format "org-html-%s-format" type))) - t)) - (cadr - (assoc-string - "en" - (eval - (intern (format "org-html-%s-format" type))) - t))) - spec)))))) + (and (plist-get info :with-date) + (org-string-nw-p date) + (format "<p class=\"date\">%s: %s</p>\n" + (org-html--translate "Date" info) + date)) + (and (plist-get info :with-author) + (org-string-nw-p author) + (format "<p class=\"author\">%s: %s</p>\n" + (org-html--translate "Author" info) + author)) + (and (plist-get info :with-email) + (org-string-nw-p email) + (format "<p class=\"email\">%s: %s</p>\n" + (org-html--translate "Email" info) + email)) + (and (plist-get info :time-stamp-file) + (format + "<p class=\"date\">%s: %s</p>\n" + (org-html--translate "Created" info) + (format-time-string + (plist-get info :html-metadata-timestamp-format)))) + (and (plist-get info :with-creator) + (org-string-nw-p creator) + (format "<p class=\"creator\">%s</p>\n" creator)) + (and (org-string-nw-p validation-link) + (format "<p class=\"validation\">%s</p>\n" + validation-link))))) + (t + (let ((formats (plist-get info (if (eq type 'preamble) + :html-preamble-format + :html-postamble-format))) + (language (plist-get info :language))) + (format-spec + (cadr (or (assoc-string language formats t) + (assoc-string "en" formats t))) + spec))))))) (let ((div (assq type (plist-get info :html-divs)))) (when (org-string-nw-p section-contents) (concat @@ -2089,12 +2124,12 @@ holding export options." ;; Postamble. (org-html--build-pre/postamble 'postamble info) ;; Possibly use the Klipse library live code blocks. - (if (plist-get info :html-klipsify-src) - (concat "<script>" (plist-get info :html-klipse-selection-script) - "</script><script src=\"" - org-html-klipse-js - "\"></script><link rel=\"stylesheet\" type=\"text/css\" href=\"" - org-html-klipse-css "\"/>")) + (when (plist-get info :html-klipsify-src) + (concat "<script>" (plist-get info :html-klipse-selection-script) + "</script><script src=\"" + org-html-klipse-js + "\"></script><link rel=\"stylesheet\" type=\"text/css\" href=\"" + org-html-klipse-css "\"/>")) ;; Closing document. "</body>\n</html>")) @@ -2160,12 +2195,10 @@ is the language used for CODE, as a string, or nil." ;; Plain text explicitly set. ((not org-html-htmlize-output-type) (org-html-encode-plain-text code)) ;; No htmlize library or an inferior version of htmlize. - ((not (and (or (require 'htmlize nil t) - (error "Please install htmlize from \ -https://github.com/hniksic/emacs-htmlize")) - (fboundp 'htmlize-region-for-paste))) + ((not (progn (require 'htmlize nil t) + (fboundp 'htmlize-region-for-paste))) ;; Emit a warning. - (message "Cannot fontify src block (htmlize.el >= 1.34 required)") + (message "Cannot fontify source block (htmlize.el >= 1.34 required)") (org-html-encode-plain-text code)) (t ;; Map language @@ -2208,14 +2241,15 @@ https://github.com/hniksic/emacs-htmlize")) (if (and beg end) (substring code beg end) code))))))))) (defun org-html-do-format-code - (code &optional lang refs retain-labels num-start) + (code &optional lang refs retain-labels num-start wrap-lines) "Format CODE string as source code. -Optional arguments LANG, REFS, RETAIN-LABELS and NUM-START are, -respectively, the language of the source code, as a string, an +Optional arguments LANG, REFS, RETAIN-LABELS, NUM-START, WRAP-LINES +are, respectively, the language of the source code, as a string, an alist between line numbers and references (as returned by `org-export-unravel-code'), a boolean specifying if labels should -appear in the source code, and the number associated to the first -line of code." +appear in the source code, the number associated to the first +line of code, and a boolean specifying if lines of code should be +wrapped in code elements." (let* ((code-lines (split-string code "\n")) (code-length (length code-lines)) (num-fmt @@ -2233,7 +2267,13 @@ line of code." (format "<span class=\"linenr\">%s</span>" (format num-fmt line-num))) ;; Transcoded src line. - loc + (if wrap-lines + (format "<code%s>%s</code>" + (if num-start + (format " data-ox-html-linenr=\"%s\"" line-num) + "") + loc) + loc) ;; Add label, if needed. (when (and ref retain-labels) (format " (%s)" ref)))) ;; Mark transcoded line as an anchor, if needed. @@ -2244,18 +2284,20 @@ line of code." (defun org-html-format-code (element info) "Format contents of ELEMENT as source code. -ELEMENT is either an example block or a src block. INFO is -a plist used as a communication channel." +ELEMENT is either an example or a source block. INFO is a plist +used as a communication channel." (let* ((lang (org-element-property :language element)) ;; Extract code and references. (code-info (org-export-unravel-code element)) (code (car code-info)) (refs (cdr code-info)) - ;; Does the src block contain labels? + ;; Does the source block contain labels? (retain-labels (org-element-property :retain-labels element)) ;; Does it have line numbers? - (num-start (org-export-get-loc element info))) - (org-html-do-format-code code lang refs retain-labels num-start))) + (num-start (org-export-get-loc element info)) + ;; Should lines be wrapped in code elements? + (wrap-lines (plist-get info :html-wrap-src-lines))) + (org-html-do-format-code code lang refs retain-labels num-start wrap-lines))) ;;; Tables of Contents @@ -2580,18 +2622,12 @@ holding contextual information." (full-text (funcall (plist-get info :html-format-headline-function) todo todo-type priority text tags info)) (contents (or contents "")) - (ids (delq nil - (list (org-element-property :CUSTOM_ID headline) - (org-export-get-reference headline info) - (org-element-property :ID headline)))) - (preferred-id (car ids)) - (extra-ids - (mapconcat - (lambda (id) - (org-html--anchor - (if (org-uuidgen-p id) (concat "ID-" id) id) - nil nil info)) - (cdr ids) ""))) + (id (or (org-element-property :CUSTOM_ID headline) + (org-export-get-reference headline info))) + (formatted-text + (if (plist-get info :html-self-link-headlines) + (format "<a href=\"#%s\">%s</a>" id full-text) + full-text))) (if (org-export-low-level-p headline info) ;; This is a deep sub-tree: export it as a list item. (let* ((html-type (if numberedp "ol" "ul"))) @@ -2600,15 +2636,16 @@ holding contextual information." (apply #'format "<%s class=\"org-%s\">\n" (make-list 2 html-type))) (org-html-format-list-item - contents (if numberedp 'ordered 'unordered) - nil info nil - (concat (org-html--anchor preferred-id nil nil info) - extra-ids - full-text)) "\n" + contents (if numberedp 'ordered 'unordered) + nil info nil + (concat (org-html--anchor id nil nil info) formatted-text)) "\n" (and (org-export-last-sibling-p headline info) (format "</%s>\n" html-type)))) ;; Standard headline. Export it as a section. - (let ((extra-class (org-element-property :HTML_CONTAINER_CLASS headline)) + (let ((extra-class + (org-element-property :HTML_CONTAINER_CLASS headline)) + (headline-class + (org-element-property :HTML_HEADLINE_CLASS headline)) (first-content (car (org-element-contents headline)))) (format "<%s id=\"%s\" class=\"%s\">%s%s</%s>\n" (org-html--container headline info) @@ -2617,17 +2654,18 @@ holding contextual information." (concat (format "outline-%d" level) (and extra-class " ") extra-class) - (format "\n<h%d id=\"%s\">%s%s</h%d>\n" + (format "\n<h%d id=\"%s\"%s>%s</h%d>\n" level - preferred-id - extra-ids + id + (if (not headline-class) "" + (format " class=\"%s\"" headline-class)) (concat (and numberedp (format "<span class=\"section-number-%d\">%s</span> " level (mapconcat #'number-to-string numbers "."))) - full-text) + formatted-text) level) ;; When there is no section, pretend there is an ;; empty one to get the correct <div @@ -2795,8 +2833,13 @@ CONTENTS is nil. INFO is a plist holding contextual information." ((string-match "\\<headlines\\>" value) (let ((depth (and (string-match "\\<[0-9]+\\>" value) (string-to-number (match-string 0 value)))) - (localp (string-match-p "\\<local\\>" value))) - (org-html-toc depth info (and localp keyword)))) + (scope + (cond + ((string-match ":target +\\(\".+?\"\\|\\S-+\\)" value) ;link + (org-export-resolve-link + (org-strip-quotes (match-string 1 value)) info)) + ((string-match-p "\\<local\\>" value) keyword)))) ;local + (org-html-toc depth info scope))) ((string= "listings" value) (org-html-list-of-listings info)) ((string= "tables" value) (org-html-list-of-tables info)))))))) @@ -2837,26 +2880,73 @@ INFO is a plist containing export properties." "Creating LaTeX Image..." nil processing-type) (buffer-string)))) +(defun org-html--wrap-latex-environment (contents _ &optional caption label) + "Wrap CONTENTS string within appropriate environment for equations. +When optional arguments CAPTION and LABEL are given, use them for +caption and \"id\" attribute." + (format "\n<div%s class=\"equation-container\">\n%s%s\n</div>" + ;; ID. + (if (org-string-nw-p label) (format " id=\"%s\"" label) "") + ;; Contents. + (format "<span class=\"equation\">\n%s\n</span>" contents) + ;; Caption. + (if (not (org-string-nw-p caption)) "" + (format "\n<span class=\"equation-label\">\n%s\n</span>" + caption)))) + +(defun org-html--math-environment-p (element &optional _) + "Non-nil when ELEMENT is a LaTeX math environment. +Math environments match the regular expression defined in +`org-latex-math-environments-re'. This function is meant to be +used as a predicate for `org-export-get-ordinal' or a value to +`org-html-standalone-image-predicate'." + (string-match-p org-latex-math-environments-re + (org-element-property :value element))) + +(defun org-html--unlabel-latex-environment (latex-frag) + "Change environment in LATEX-FRAG string to an unnumbered one. +For instance, change an 'equation' environment to 'equation*'." + (replace-regexp-in-string + "\\`[ \t]*\\\\begin{\\([^*]+?\\)}" + "\\1*" + (replace-regexp-in-string "^[ \t]*\\\\end{\\([^*]+?\\)}[ \r\t\n]*\\'" + "\\1*" + latex-frag nil nil 1) + nil nil 1)) + (defun org-html-latex-environment (latex-environment _contents info) "Transcode a LATEX-ENVIRONMENT element from Org to HTML. CONTENTS is nil. INFO is a plist holding contextual information." (let ((processing-type (plist-get info :with-latex)) (latex-frag (org-remove-indentation (org-element-property :value latex-environment))) - (attributes (org-export-read-attribute :attr_html latex-environment))) + (attributes (org-export-read-attribute :attr_html latex-environment)) + (label (and (org-element-property :name latex-environment) + (org-export-get-reference latex-environment info))) + (caption (number-to-string + (org-export-get-ordinal + latex-environment info nil + #'org-html--math-environment-p)))) (cond ((memq processing-type '(t mathjax)) - (org-html-format-latex latex-frag 'mathjax info)) + (org-html-format-latex + (if (org-string-nw-p label) + (replace-regexp-in-string "\\`.*" + (format "\\&\n\\\\label{%s}" label) + latex-frag) + latex-frag) + 'mathjax info)) ((assq processing-type org-preview-latex-process-alist) (let ((formula-link - (org-html-format-latex latex-frag processing-type info))) - (when (and formula-link (string-match "file:\\([^]]*\\)" formula-link)) - ;; Do not provide a caption or a name to be consistent with - ;; `mathjax' handling. - (org-html--wrap-image - (org-html--format-image - (match-string 1 formula-link) attributes info) info)))) - (t latex-frag)))) + (org-html-format-latex + (org-html--unlabel-latex-environment latex-frag) + processing-type info))) + (when (and formula-link (string-match "file:\\([^]]*\\)" formula-link)) + (org-html--wrap-latex-environment + (org-html--format-image + (match-string 1 formula-link) attributes info) + info caption label)))) + (t (org-html--wrap-latex-environment latex-frag info caption label))))) ;;;; Latex Fragment @@ -2972,7 +3062,7 @@ INFO is a plist holding contextual information. See (path (cond ((member type '("http" "https" "ftp" "mailto" "news")) - (url-encode-url (org-link-unescape (concat type ":" raw-path)))) + (url-encode-url (concat type ":" raw-path))) ((string= type "file") ;; During publishing, turn absolute file names belonging ;; to base directory into relative file names. Otherwise, @@ -2994,30 +3084,31 @@ INFO is a plist holding contextual information. See ;; relative to a custom-id, a headline title, a name or ;; a target. (let ((option (org-element-property :search-option link))) - (cond ((not option) raw-path) - ;; Since HTML back-end use custom-id value as-is, - ;; resolving is them is trivial. - ((eq (string-to-char option) ?#) (concat raw-path option)) - (t - (concat raw-path - "#" - (org-publish-resolve-external-link - option - (org-element-property :path link))))))) + (if (not option) raw-path + (let ((path (org-element-property :path link))) + (concat raw-path + "#" + (org-publish-resolve-external-link option path t)))))) (t raw-path))) - ;; Extract attributes from parent's paragraph. HACK: Only do - ;; this for the first link in parent (inner image link for - ;; inline images). This is needed as long as attributes - ;; cannot be set on a per link basis. (attributes-plist - (let* ((parent (org-export-get-parent-element link)) - (link (let ((container (org-export-get-parent link))) - (if (and (eq (org-element-type container) 'link) - (org-html-inline-image-p link info)) - container - link)))) - (and (eq (org-element-map parent 'link 'identity info t) link) - (org-export-read-attribute :attr_html parent)))) + (org-combine-plists + ;; Extract attributes from parent's paragraph. HACK: Only + ;; do this for the first link in parent (inner image link + ;; for inline images). This is needed as long as + ;; attributes cannot be set on a per link basis. + (let* ((parent (org-export-get-parent-element link)) + (link (let ((container (org-export-get-parent link))) + (if (and (eq 'link (org-element-type container)) + (org-html-inline-image-p link info)) + container + link)))) + (and (eq link (org-element-map parent 'link #'identity info t)) + (org-export-read-attribute :attr_html parent))) + ;; Also add attributes from link itself. Currently, those + ;; need to be added programmatically before `org-html-link' + ;; is invoked, for example, by backends building upon HTML + ;; export. + (org-export-read-attribute :attr_html link))) (attributes (let ((attr (org-html--make-attribute-string attributes-plist))) (if (org-string-nw-p attr) (concat " " attr) "")))) @@ -3081,23 +3172,37 @@ INFO is a plist holding contextual information. See (format "<a href=\"#%s\"%s>%s</a>" href attributes desc))) ;; Fuzzy link points to a target or an element. (_ - (let* ((ref (org-export-get-reference destination info)) - (org-html-standalone-image-predicate - #'org-html--has-caption-p) - (number (cond - (desc nil) - ((org-html-standalone-image-p destination info) - (org-export-get-ordinal - (org-element-map destination 'link - #'identity info t) - info 'link 'org-html-standalone-image-p)) - (t (org-export-get-ordinal - destination info nil 'org-html--has-caption-p)))) - (desc (cond (desc) - ((not number) "No description for this link") - ((numberp number) (number-to-string number)) - (t (mapconcat #'number-to-string number "."))))) - (format "<a href=\"#%s\"%s>%s</a>" ref attributes desc)))))) + (if (and destination + (memq (plist-get info :with-latex) '(mathjax t)) + (eq 'latex-environment (org-element-type destination)) + (eq 'math (org-latex--environment-type destination))) + ;; Caption and labels are introduced within LaTeX + ;; environment. Use "eqref" macro to refer to those in + ;; the document. + (format "\\eqref{%s}" + (org-export-get-reference destination info)) + (let* ((ref (org-export-get-reference destination info)) + (org-html-standalone-image-predicate + #'org-html--has-caption-p) + (counter-predicate + (if (eq 'latex-environment (org-element-type destination)) + #'org-html--math-environment-p + #'org-html--has-caption-p)) + (number + (cond + (desc nil) + ((org-html-standalone-image-p destination info) + (org-export-get-ordinal + (org-element-map destination 'link #'identity info t) + info 'link 'org-html-standalone-image-p)) + (t (org-export-get-ordinal + destination info nil counter-predicate)))) + (desc + (cond (desc) + ((not number) "No description for this link") + ((numberp number) (number-to-string number)) + (t (mapconcat #'number-to-string number "."))))) + (format "<a href=\"#%s\"%s>%s</a>" ref attributes desc))))))) ;; Coderef: replace link with the reference name or the ;; equivalent line number. ((string= type "coderef") @@ -3111,18 +3216,18 @@ INFO is a plist holding contextual information. See (format (org-export-get-coderef-format path desc) (org-export-resolve-coderef path info))))) ;; External link with a description part. - ((and path desc) (format "<a href=\"%s\"%s>%s</a>" - (org-html-encode-plain-text path) - attributes - desc)) + ((and path desc) + (format "<a href=\"%s\"%s>%s</a>" + (org-html-encode-plain-text path) + attributes + desc)) ;; External link without a description part. - (path (let ((path (org-html-encode-plain-text path))) - (format "<a href=\"%s\"%s>%s</a>" - path - attributes - (org-link-unescape path)))) + (path + (let ((path (org-html-encode-plain-text path))) + (format "<a href=\"%s\"%s>%s</a>" path attributes path))) ;; No path, only description. Try to do something useful. - (t (format "<i>%s</i>" desc))))) + (t + (format "<i>%s</i>" desc))))) ;;;; Node Property @@ -3665,8 +3770,8 @@ contextual information." (with-temp-buffer (insert contents) (set-auto-mode t) - (if (plist-get info :html-indent) - (indent-region (point-min) (point-max))) + (when (plist-get info :html-indent) + (indent-region (point-min) (point-max))) (buffer-substring-no-properties (point-min) (point-max)))) diff --git a/lisp/org/ox-icalendar.el b/lisp/org/ox-icalendar.el index f66e100f6a5..15c572dc1af 100644 --- a/lisp/org/ox-icalendar.el +++ b/lisp/org/ox-icalendar.el @@ -33,7 +33,7 @@ (require 'cl-lib) (require 'ox-ascii) -(declare-function org-bbdb-anniv-export-ical "org-bbdb" nil) +(declare-function org-bbdb-anniv-export-ical "ol-bbdb" nil) @@ -87,37 +87,66 @@ keyword." This is a list with possibly several symbols in it. Valid symbols are: -`event-if-todo' Deadlines in TODO entries become calendar events. -`event-if-not-todo' Deadlines in non-TODO entries become calendar events. -`todo-due' Use deadlines in TODO entries as due-dates." +`event-if-todo' + + Deadlines in TODO entries become calendar events. + +`event-if-todo-not-done' + + Deadlines in TODO entries with not-DONE state become events. + +`event-if-not-todo' + + Deadlines in non-TODO entries become calendar events. + +`todo-due' + + Use deadlines in TODO entries as due-dates." :group 'org-export-icalendar - :type '(set :greedy t - (const :tag "Deadlines in non-TODO entries become events" - event-if-not-todo) - (const :tag "Deadline in TODO entries become events" - event-if-todo) - (const :tag "Deadlines in TODO entries become due-dates" - todo-due))) + :type + '(set :greedy t + (const :tag "DEADLINE in non-TODO entries become events" + event-if-not-todo) + (const :tag "DEADLINE in TODO entries become events" + event-if-todo) + (const :tag "DEADLINE in TODO entries with not-DONE state become events" + event-if-todo-not-done) + (const :tag "DEADLINE in TODO entries become due-dates" + todo-due))) (defcustom org-icalendar-use-scheduled '(todo-start) "Contexts where iCalendar export should use a scheduling time stamp. This is a list with possibly several symbols in it. Valid symbols are: -`event-if-todo' Scheduling time stamps in TODO entries become an event. -`event-if-not-todo' Scheduling time stamps in non-TODO entries become an event. -`todo-start' Scheduling time stamps in TODO entries become start date. - Some calendar applications show TODO entries only after - that date." +`event-if-todo' + + Scheduling time stamps in TODO entries become an event. + +`event-if-todo-not-done' + + Scheduling time stamps in TODO entries with not-DONE state + become events. + +`event-if-not-todo' + + Scheduling time stamps in non-TODO entries become an event. + +`todo-start' + + Scheduling time stamps in TODO entries become start date. Some + calendar applications show TODO entries only after that date." :group 'org-export-icalendar - :type '(set :greedy t - (const :tag - "SCHEDULED timestamps in non-TODO entries become events" - event-if-not-todo) - (const :tag "SCHEDULED timestamps in TODO entries become events" - event-if-todo) - (const :tag "SCHEDULED in TODO entries become start date" - todo-start))) + :type + '(set :greedy t + (const :tag "SCHEDULED timestamps in non-TODO entries become events" + event-if-not-todo) + (const :tag "SCHEDULED timestamps in TODO entries become events" + event-if-todo) + (const :tag "SCHEDULED in TODO entries with not-DONE state become events" + event-if-todo-not-done) + (const :tag "SCHEDULED in TODO entries become start date" + todo-start))) (defcustom org-icalendar-categories '(local-tags category) "Items that should be entered into the \"categories\" field. @@ -317,7 +346,7 @@ A headline is blocked when either done first or is a child of a blocked grandparent entry." (or ;; Check if any child is not done. - (org-element-map headline 'headline + (org-element-map (org-element-contents headline) 'headline (lambda (hl) (eq (org-element-property :todo-type hl) 'todo)) info 'first-match) ;; Check :ORDERED: node property. @@ -540,6 +569,10 @@ inlinetask within the section." (org-export-get-node-property :LOCATION entry (org-property-inherit-p "LOCATION")))) + (class (org-icalendar-cleanup-string + (org-export-get-node-property + :CLASS entry + (org-property-inherit-p "CLASS")))) ;; Build description of the entry from associated section ;; (headline) or contents (inlinetask). (desc @@ -562,20 +595,28 @@ inlinetask within the section." ;; Events: Delegate to `org-icalendar--vevent' to generate ;; "VEVENT" component from scheduled, deadline, or any ;; timestamp in the entry. - (let ((deadline (org-element-property :deadline entry))) + (let ((deadline (org-element-property :deadline entry)) + (use-deadline (plist-get info :icalendar-use-deadline))) (and deadline - (memq (if todo-type 'event-if-todo 'event-if-not-todo) - org-icalendar-use-deadline) + (pcase todo-type + (`todo (or (memq 'event-if-todo-not-done use-deadline) + (memq 'event-if-todo use-deadline))) + (`done (memq 'event-if-todo use-deadline)) + (_ (memq 'event-if-not-todo use-deadline))) (org-icalendar--vevent entry deadline (concat "DL-" uid) - (concat "DL: " summary) loc desc cat tz))) - (let ((scheduled (org-element-property :scheduled entry))) + (concat "DL: " summary) loc desc cat tz class))) + (let ((scheduled (org-element-property :scheduled entry)) + (use-scheduled (plist-get info :icalendar-use-scheduled))) (and scheduled - (memq (if todo-type 'event-if-todo 'event-if-not-todo) - org-icalendar-use-scheduled) + (pcase todo-type + (`todo (or (memq 'event-if-todo-not-done use-scheduled) + (memq 'event-if-todo use-scheduled))) + (`done (memq 'event-if-todo use-scheduled)) + (_ (memq 'event-if-not-todo use-scheduled))) (org-icalendar--vevent entry scheduled (concat "SC-" uid) - (concat "S: " summary) loc desc cat tz))) + (concat "S: " summary) loc desc cat tz class))) ;; When collecting plain timestamps from a headline and its ;; title, skip inlinetasks since collection will happen once ;; ENTRY is one of them. @@ -593,7 +634,7 @@ inlinetask within the section." ((t) t))) (let ((uid (format "TS%d-%s" (cl-incf counter) uid))) (org-icalendar--vevent - entry ts uid summary loc desc cat tz)))) + entry ts uid summary loc desc cat tz class)))) info nil (and (eq type 'headline) 'inlinetask)) "")) ;; Task: First check if it is appropriate to export it. If @@ -607,7 +648,7 @@ inlinetask within the section." (not (org-icalendar-blocked-headline-p entry info)))) ((t) (eq todo-type 'todo)))) - (org-icalendar--vtodo entry uid summary loc desc cat tz)) + (org-icalendar--vtodo entry uid summary loc desc cat tz class)) ;; Diary-sexp: Collect every diary-sexp element within ENTRY ;; and its title, and transcode them. If ENTRY is ;; a headline, skip inlinetasks: they will be handled @@ -638,7 +679,7 @@ inlinetask within the section." contents)))) (defun org-icalendar--vevent - (entry timestamp uid summary location description categories timezone) + (entry timestamp uid summary location description categories timezone class) "Create a VEVENT component. ENTRY is either a headline or an inlinetask element. TIMESTAMP @@ -648,7 +689,9 @@ summary or subject for the event. LOCATION defines the intended venue for the event. DESCRIPTION provides the complete description of the event. CATEGORIES defines the categories the event belongs to. TIMEZONE specifies a time zone for this event -only. +only. CLASS contains the visibility attribute. Three of them +(\"PUBLIC\", \"CONFIDENTIAL\", and \"PRIVATE\") are predefined, others +should be treated as \"PRIVATE\" if they are unknown to the iCalendar server. Return VEVENT component as a string." (org-icalendar-fold-string @@ -669,6 +712,7 @@ Return VEVENT component as a string." (org-element-property :repeater-value timestamp))) "SUMMARY:" summary "\n" (and (org-string-nw-p location) (format "LOCATION:%s\n" location)) + (and (org-string-nw-p class) (format "CLASS:%s\n" class)) (and (org-string-nw-p description) (format "DESCRIPTION:%s\n" description)) "CATEGORIES:" categories "\n" @@ -677,7 +721,7 @@ Return VEVENT component as a string." "END:VEVENT")))) (defun org-icalendar--vtodo - (entry uid summary location description categories timezone) + (entry uid summary location description categories timezone class) "Create a VTODO component. ENTRY is either a headline or an inlinetask element. UID is the @@ -712,6 +756,7 @@ Return VTODO component as a string." "\n")) "SUMMARY:" summary "\n" (and (org-string-nw-p location) (format "LOCATION:%s\n" location)) + (and (org-string-nw-p class) (format "CLASS:%s\n" class)) (and (org-string-nw-p description) (format "DESCRIPTION:%s\n" description)) "CATEGORIES:" categories "\n" @@ -963,7 +1008,7 @@ FILES is a list of files to build the calendar from." files "") ;; BBDB anniversaries. (when (and org-icalendar-include-bbdb-anniversaries - (require 'org-bbdb nil t)) + (require 'ol-bbdb nil t)) (with-output-to-string (org-bbdb-anniv-export-ical))))))) (run-hook-with-args 'org-icalendar-after-save-hook org-icalendar-combined-agenda-file)) diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el index 1ec835a47e9..65f40fb7a15 100644 --- a/lisp/org/ox-latex.el +++ b/lisp/org/ox-latex.el @@ -127,6 +127,7 @@ (:latex-format-headline-function nil nil org-latex-format-headline-function) (:latex-format-inlinetask-function nil nil org-latex-format-inlinetask-function) (:latex-hyperref-template nil nil org-latex-hyperref-template t) + (:latex-image-default-scale nil nil org-latex-image-default-scale) (:latex-image-default-height nil nil org-latex-image-default-height) (:latex-image-default-option nil nil org-latex-image-default-option) (:latex-image-default-width nil nil org-latex-image-default-width) @@ -159,7 +160,6 @@ (defconst org-latex-babel-language-alist '(("af" . "afrikaans") ("bg" . "bulgarian") - ("bt-br" . "brazilian") ("ca" . "catalan") ("cs" . "czech") ("cy" . "welsh") @@ -179,7 +179,7 @@ ("et" . "estonian") ("eu" . "basque") ("fi" . "finnish") - ("fr" . "frenchb") + ("fr" . "french") ("fr-ca" . "canadien") ("gl" . "galician") ("hr" . "croatian") @@ -195,6 +195,7 @@ ("no" . "norsk") ("pl" . "polish") ("pt" . "portuguese") + ("pt-br" . "brazilian") ("ro" . "romanian") ("ru" . "russian") ("sa" . "sanskrit") @@ -211,13 +212,12 @@ (defconst org-latex-polyglossia-language-alist '(("am" "amharic") - ("ast" "asturian") ("ar" "arabic") - ("bo" "tibetan") - ("bn" "bengali") + ("ast" "asturian") ("bg" "bulgarian") + ("bn" "bengali") + ("bo" "tibetan") ("br" "breton") - ("bt-br" "brazilian") ("ca" "catalan") ("cop" "coptic") ("cs" "czech") @@ -226,6 +226,7 @@ ("de" "german" "german") ("de-at" "german" "austrian") ("de-de" "german" "german") + ("dsb" "lsorbian") ("dv" "divehi") ("el" "greek") ("en" "english" "usmax") @@ -247,40 +248,40 @@ ("he" "hebrew") ("hi" "hindi") ("hr" "croatian") + ("hsb" "usorbian") ("hu" "magyar") ("hy" "armenian") - ("id" "bahasai") ("ia" "interlingua") + ("id" "bahasai") ("is" "icelandic") ("it" "italian") ("kn" "kannada") ("la" "latin" "modern") - ("la-modern" "latin" "modern") ("la-classic" "latin" "classic") ("la-medieval" "latin" "medieval") + ("la-modern" "latin" "modern") ("lo" "lao") ("lt" "lithuanian") ("lv" "latvian") - ("mr" "maranthi") ("ml" "malayalam") - ("nl" "dutch") + ("mr" "maranthi") ("nb" "norsk") - ("nn" "nynorsk") ("nko" "nko") + ("nl" "dutch") + ("nn" "nynorsk") ("no" "norsk") ("oc" "occitan") ("pl" "polish") ("pms" "piedmontese") ("pt" "portuges") + ("pt-br" "brazilian") ("rm" "romansh") ("ro" "romanian") ("ru" "russian") ("sa" "sanskrit") - ("hsb" "usorbian") - ("dsb" "lsorbian") + ("se" "samin") ("sk" "slovak") ("sl" "slovenian") - ("se" "samin") ("sq" "albanian") ("sr" "serbian") ("sv" "swedish") @@ -295,8 +296,6 @@ ("vi" "vietnamese")) "Alist between language code and corresponding Polyglossia option") - - (defconst org-latex-table-matrix-macros '(("bordermatrix" . "\\cr") ("qbordermatrix" . "\\cr") ("kbordermatrix" . "\\\\")) @@ -708,6 +707,16 @@ This value will not be used if a height is provided." :package-version '(Org . "8.0") :type 'string) +(defcustom org-latex-image-default-scale "" + "Default scale for images. +This value will not be used if a width or a scale is provided, +or if the image is wrapped within a \"wrapfigure\" environment. +Scale overrides width and height." + :group 'org-export-latex + :package-version '(Org . "9.3") + :type 'string + :safe #'stringp) + (defcustom org-latex-image-default-height "" "Default height for images. This value will not be used if a width is provided, or if the @@ -810,8 +819,9 @@ attributes." :type 'boolean :safe #'booleanp) -(defcustom org-latex-table-scientific-notation "%s\\,(%s)" +(defcustom org-latex-table-scientific-notation nil "Format string to display numbers in scientific notation. + The format should have \"%s\" twice, for mantissa and exponent \(i.e., \"%s\\\\times10^{%s}\"). @@ -1026,7 +1036,7 @@ value. For example, (setq org-latex-minted-options \\='((\"bgcolor\" \"bg\") (\"frame\" \"lines\"))) -will result in src blocks being exported with +will result in source blocks being exported with \\begin{minted}[bgcolor=bg,frame=lines]{<LANG>} @@ -1047,12 +1057,13 @@ block-specific options, you may use the following syntax: (defcustom org-latex-custom-lang-environments nil "Alist mapping languages to language-specific LaTeX environments. -It is used during export of src blocks by the listings and minted -latex packages. The environment may be a simple string, composed of -only letters and numbers. In this case, the string is directly the -name of the latex environment to use. The environment may also be -a format string. In this case the format string will be directly -exported. This format string may contain these elements: +It is used during export of source blocks by the listings and +minted LaTeX packages. The environment may be a simple string, +composed of only letters and numbers. In this case, the string +is directly the name of the LaTeX environment to use. The +environment may also be a format string. In this case the format +string will be directly exported. This format string may contain +these elements: %s for the formatted source %c for the caption @@ -1074,7 +1085,7 @@ would have the effect that if Org encounters a Python source block during LaTeX export it will produce \\begin{pythoncode} - <src block body> + <source block body> \\end{pythoncode} and if Org encounters an Ocaml source block during LaTeX export it @@ -1082,7 +1093,7 @@ will produce \\begin{listing} \\begin{minted}[<attr_latex options>]{ocaml} - <src block body> + <source block body> \\end{minted} \\caption{<caption>} \\label{<label>} @@ -1221,7 +1232,7 @@ logfiles to remove, set `org-latex-logfiles-extensions'." ("Undefined control sequence" . "[undefined control sequence]")) "Alist of regular expressions and associated messages for the user. The regular expressions are used to find possible warnings in the -log of a latex-run. These warnings will be reported after +log of a LaTeX-run. These warnings will be reported after calling `org-latex-compile'." :group 'org-export-latex :version "26.1" @@ -1265,17 +1276,19 @@ Eventually, if FULL is non-nil, wrap label within \"\\label{}\"." (and (or user-label force) (if (and user-label (plist-get info :latex-prefer-user-labels)) user-label - (concat (cl-case type - (headline "sec:") - (table "tab:") - (latex-environment + (concat (pcase type + (`headline "sec:") + (`table "tab:") + (`latex-environment (and (string-match-p org-latex-math-environments-re (org-element-property :value datum)) "eq:")) - (paragraph + (`latex-matrices "eq:") + (`paragraph (and (org-element-property :caption datum) - "fig:"))) + "fig:")) + (_ nil)) (org-export-get-reference datum info)))))) (cond ((not full) label) (label (format "\\label{%s}%s" @@ -1325,7 +1338,7 @@ For non-floats, see `org-latex--wrap-label'." (t (symbol-name type*))) "")) (if short (format "[%s]" (org-export-data short info)) "") - label + (org-trim label) (org-export-data main info)))))) (defun org-latex-guess-inputenc (header) @@ -1438,26 +1451,21 @@ Return the new header." (defun org-latex--remove-packages (pkg-alist info) "Remove packages based on the current LaTeX compiler. -If the fourth argument of an element is set in pkg-alist, and it -is not a member of the LaTeX compiler of the document, the packages -is removed. See also `org-latex-compiler'. +PKG-ALIST is a list of packages, as in `org-latex-packages-alist' +and `org-latex-default-packages-alist'. If the fourth argument +of a package is neither nil nor a member of the LaTeX compiler +associated to the document, the package is removed. -Return modified pkg-alist." +Return new list of packages." (let ((compiler (or (plist-get info :latex-compiler) ""))) - (if (member-ignore-case compiler org-latex-compilers) - (delq nil - (mapcar - (lambda (pkg) - (unless (and - (listp pkg) - (let ((third (nth 3 pkg))) - (and third - (not (member-ignore-case - compiler - (if (listp third) third (list third))))))) - pkg)) - pkg-alist)) - pkg-alist))) + (if (not (member-ignore-case compiler org-latex-compilers)) pkg-alist + (cl-remove-if-not + (lambda (package) + (pcase package + (`(,_ ,_ ,_ nil) t) + (`(,_ ,_ ,_ ,compilers) (member-ignore-case compiler compilers)) + (_ t))) + pkg-alist)))) (defun org-latex--find-verb-separator (s) "Return a character not used in string S. @@ -1851,7 +1859,7 @@ CONTENTS is nil. INFO is a plist holding contextual information." CONTENTS is nil. INFO is a plist holding contextual information." (org-latex--wrap-label fixed-width - (format "\\begin{verbatim}\n%s\\end{verbatim}" + (format "\\begin{verbatim}\n%s\n\\end{verbatim}" (org-remove-indentation (org-element-property :value fixed-width))) info)) @@ -1877,9 +1885,12 @@ CONTENTS is nil. INFO is a plist holding contextual information." (org-export-get-footnote-definition footnote-reference info) info t))) ;; Use \footnotemark if reference is within another footnote - ;; reference, footnote definition or table cell. - ((org-element-lineage footnote-reference - '(footnote-reference footnote-definition table-cell)) + ;; reference, footnote definition, table cell or item's tag. + ((or (org-element-lineage footnote-reference + '(footnote-reference footnote-definition + table-cell)) + (eq 'item (org-element-type + (org-export-get-parent-element footnote-reference)))) "\\footnotemark") ;; Otherwise, define it with \footnote command. (t @@ -1890,11 +1901,11 @@ CONTENTS is nil. INFO is a plist holding contextual information." ;; reference to def. (cond ((not label) "") ((org-element-map (plist-get info :parse-tree) 'footnote-reference - (lambda (f) - (and (not (eq f footnote-reference)) - (equal (org-element-property :label f) label) - (org-trim (org-latex--label def info t t)))) - info t)) + (lambda (f) + (and (not (eq f footnote-reference)) + (equal (org-element-property :label f) label) + (org-trim (org-latex--label def info t t)))) + info t)) (t ""))) ;; Retrieve all footnote references within the footnote and ;; add their definition after it, since LaTeX doesn't support @@ -2131,8 +2142,9 @@ See `org-latex-format-inlinetask-function' for details." (when priority (format "\\framebox{\\#%c} " priority)) title (when tags - (format "\\hfill{}\\textsc{:%s:}" - (mapconcat #'org-latex--protect-text tags ":")))))) + (format "\\hfill{}\\textsc{%s}" + (org-make-tag-string + (mapcar #'org-latex--protect-text tags))))))) (concat "\\begin{center}\n" "\\fbox{\n" "\\begin{minipage}[c]{.6\\textwidth}\n" @@ -2183,12 +2195,22 @@ contextual information." (off "$\\square$") (trans "$\\boxminus$"))) (tag (let ((tag (org-element-property :tag item))) - (and tag (org-export-data tag info))))) + (and tag (org-export-data tag info)))) + ;; If there are footnotes references in tag, be sure to add + ;; their definition at the end of the item. This workaround + ;; is necessary since "\footnote{}" command is not supported + ;; in tags. + (tag-footnotes + (or (and tag (org-latex--delayed-footnotes-definitions + (org-element-property :tag item) info)) + ""))) (concat counter "\\item" (cond - ((and checkbox tag) (format "[{%s %s}] " checkbox tag)) - ((or checkbox tag) (format "[{%s}] " (or checkbox tag))) + ((and checkbox tag) + (format "[{%s %s}] %s" checkbox tag tag-footnotes)) + ((or checkbox tag) + (format "[{%s}] %s" (or checkbox tag) tag-footnotes)) ;; Without a tag or a check-box, if CONTENTS starts with ;; an opening square bracket, add "\relax" to "\item", ;; unless the brackets comes from an initial export @@ -2203,14 +2225,7 @@ contextual information." 'latex))))))) "\\relax ") (t " ")) - (and contents (org-trim contents)) - ;; If there are footnotes references in tag, be sure to - ;; add their definition at the end of the item. This - ;; workaround is necessary since "\footnote{}" command is - ;; not supported in tags. - (and tag - (org-latex--delayed-footnotes-definitions - (org-element-property :tag item) info))))) + (and contents (org-trim contents))))) ;;;; Keyword @@ -2370,13 +2385,18 @@ used as a communication channel." (if (plist-member attr :center) (plist-get attr :center) (plist-get info :latex-images-centered))) (comment-include (if (plist-get attr :comment-include) "%" "")) - ;; It is possible to specify width and height in the - ;; ATTR_LATEX line, and also via default variables. - (width (cond ((plist-get attr :width)) + ;; It is possible to specify scale or width and height in + ;; the ATTR_LATEX line, and also via default variables. + (scale (cond ((eq float 'wrap) "") + ((plist-get attr :scale)) + (t (plist-get info :latex-image-default-scale)))) + (width (cond ((org-string-nw-p scale) "") + ((plist-get attr :width)) ((plist-get attr :height) "") ((eq float 'wrap) "0.48\\textwidth") (t (plist-get info :latex-image-default-width)))) - (height (cond ((plist-get attr :height)) + (height (cond ((org-string-nw-p scale) "") + ((plist-get attr :height)) ((or (plist-get attr :width) (memq float '(figure wrap))) "") (t (plist-get info :latex-image-default-height)))) @@ -2398,18 +2418,21 @@ used as a communication channel." (format "\\begin{tikzpicture}[%s]\n%s\n\\end{tikzpicture}" options image-code))) - (when (or (org-string-nw-p width) (org-string-nw-p height)) - (setq image-code (format "\\resizebox{%s}{%s}{%s}" - (if (org-string-nw-p width) width "!") - (if (org-string-nw-p height) height "!") - image-code)))) + (setq image-code + (cond ((org-string-nw-p scale) + (format "\\scalebox{%s}{%s}" scale image-code)) + ((or (org-string-nw-p width) (org-string-nw-p height)) + (format "\\resizebox{%s}{%s}{%s}" + (if (org-string-nw-p width) width "!") + (if (org-string-nw-p height) height "!") + image-code))))) ;; For other images: - ;; - add width and height to options. + ;; - add scale, or width and height to options. ;; - include the image with \includegraphics. - (when (org-string-nw-p width) - (setq options (concat options ",width=" width))) - (when (org-string-nw-p height) - (setq options (concat options ",height=" height))) + (if (org-string-nw-p scale) + (setq options (concat options ",scale=" scale)) + (when (org-string-nw-p width) (setq options (concat options ",width=" width))) + (when (org-string-nw-p height) (setq options (concat options ",height=" height)))) (let ((search-option (org-element-property :search-option link))) (when (and search-option (equal filetype "pdf") @@ -2496,8 +2519,10 @@ INFO is a plist holding contextual information. See (path (org-latex--protect-text (cond ((member type '("http" "https" "ftp" "mailto" "doi")) (concat type ":" raw-path)) - ((string= type "file") (org-export-file-uri raw-path)) - (t raw-path))))) + ((string= type "file") + (org-export-file-uri raw-path)) + (t + raw-path))))) (cond ;; Link type is handled by a special function. ((org-export-custom-protocol-maybe link desc 'latex)) @@ -2514,9 +2539,10 @@ INFO is a plist holding contextual information. See ;; Links pointing to a headline: Find destination and build ;; appropriate referencing command. ((member type '("custom-id" "fuzzy" "id")) - (let ((destination (if (string= type "fuzzy") - (org-export-resolve-fuzzy-link link info) - (org-export-resolve-id-link link info)))) + (let ((destination + (if (string= type "fuzzy") + (org-export-resolve-fuzzy-link link info 'latex-matrices) + (org-export-resolve-id-link link info)))) (cl-case (org-element-type destination) ;; Id link points to an external file. (plain-text @@ -2709,12 +2735,18 @@ it." 'latex-matrices))) (let* ((caption (and (not (string= mode "inline-math")) (org-element-property :caption table))) + (name (and (not (string= mode "inline-math")) + (org-element-property :name table))) (matrices (list 'latex-matrices - (list :caption caption + ;; Inherit name from the first table. + (list :name name + ;; FIXME: what syntax for captions? + ;; + ;; :caption caption :markup (cond ((string= mode "inline-math") 'inline) - (caption 'equation) + ((or caption name) 'equation) (t 'math))))) (previous table) (next (org-export-get-next-element table info))) @@ -2729,6 +2761,8 @@ it." :attr_latex next :mode) (plist-get info :latex-default-table-mode)) mode)) + (org-element-put-property table :name nil) + (org-element-put-property table :caption nil) (org-element-extract-element previous) (org-element-adopt-elements matrices previous) (setq previous next)) @@ -2738,20 +2772,29 @@ it." (org-element-put-property matrices :post-blank (org-element-property :post-blank previous)) (org-element-put-property previous :post-blank 0) + (org-element-put-property table :name nil) + (org-element-put-property table :caption nil) (org-element-extract-element previous) (org-element-adopt-elements matrices previous)))))) info) data) -(defun org-latex-matrices (matrices contents _info) +(defun org-latex-matrices (matrices contents info) "Transcode a MATRICES element from Org to LaTeX. CONTENTS is a string. INFO is a plist used as a communication channel." - (format (cl-case (org-element-property :markup matrices) - (inline "\\(%s\\)") - (equation "\\begin{equation}\n%s\\end{equation}") - (t "\\[\n%s\\]")) - contents)) + (pcase (org-element-property :markup matrices) + (`inline (format "\\(%s\\)" contents)) + (`equation + (let ((caption (org-latex--caption/label-string matrices info)) + (caption-above? (org-latex--caption-above-p matrices info))) + (concat "\\begin{equation}\n" + (and caption-above? caption) + contents + (and (not caption-above?) caption) + "\\end{equation}"))) + (_ + (format "\\[\n%s\\]" contents)))) ;;;; Pseudo Object: LaTeX Math Block @@ -2764,24 +2807,21 @@ channel." DATA is a parse tree or a secondary string. INFO is a plist containing export options. Modify DATA by side-effect and return it." (let ((valid-object-p - ;; Non-nil when OBJ can be added to the latex math block B. - (lambda (obj b) - (pcase (org-element-type obj) - (`entity (org-element-property :latex-math-p obj)) + ;; Non-nil when OBJECT can be added to a latex math block. + (lambda (object) + (pcase (org-element-type object) + (`entity (org-element-property :latex-math-p object)) (`latex-fragment - (let ((value (org-element-property :value obj))) + (let ((value (org-element-property :value object))) (or (string-prefix-p "\\(" value) - (string-match-p "\\`\\$[^$]" value)))) - ((and type (or `subscript `superscript)) - (not (memq type (mapcar #'org-element-type - (org-element-contents b))))))))) - (org-element-map data '(entity latex-fragment subscript superscript) + (string-match-p "\\`\\$[^$]" value)))))))) + (org-element-map data '(entity latex-fragment) (lambda (object) ;; Skip objects already wrapped. (when (and (not (eq (org-element-type (org-element-property :parent object)) 'latex-math-block)) - (funcall valid-object-p object nil)) + (funcall valid-object-p object)) (let ((math-block (list 'latex-math-block nil)) (next-elements (org-export-get-next-element object info t)) (last object)) @@ -2793,20 +2833,17 @@ containing export options. Modify DATA by side-effect and return it." ;; MATH-BLOCK swallows consecutive math objects. (catch 'exit (dolist (next next-elements) - (unless (funcall valid-object-p next math-block) - (throw 'exit nil)) + (unless (funcall valid-object-p next) (throw 'exit nil)) (org-element-extract-element next) (org-element-adopt-elements math-block next) ;; Eschew the case: \beta$x$ -> \(\betax\). - (unless (memq (org-element-type next) - '(subscript superscript)) - (org-element-put-property last :post-blank 1)) + (org-element-put-property last :post-blank 1) (setq last next) (when (> (or (org-element-property :post-blank next) 0) 0) (throw 'exit nil))))) (org-element-put-property math-block :post-blank (org-element-property :post-blank last))))) - info nil '(subscript superscript latex-math-block) t) + info nil '(latex-math-block) t) ;; Return updated DATA. data)) @@ -2883,7 +2920,7 @@ contextual information." (listings (plist-get info :latex-listings))) (cond ;; Case 1. No source fontification. - ((not listings) + ((or (not lang) (not listings)) (let* ((caption-str (org-latex--caption/label-string src-block info)) (float-env (cond ((string= "multicolumn" float) @@ -2920,21 +2957,23 @@ contextual information." ;; Case 3. Use minted package. ((eq listings 'minted) (let* ((caption-str (org-latex--caption/label-string src-block info)) + (placement (or (org-unbracket-string "[" "]" (plist-get attributes :placement)) + (plist-get info :latex-default-figure-position))) (float-env (cond ((string= "multicolumn" float) (format "\\begin{listing*}[%s]\n%s%%s\n%s\\end{listing*}" - (plist-get info :latex-default-figure-position) + placement (if caption-above-p caption-str "") (if caption-above-p "" caption-str))) (caption (format "\\begin{listing}[%s]\n%s%%s\n%s\\end{listing}" - (plist-get info :latex-default-figure-position) + placement (if caption-above-p caption-str "") (if caption-above-p "" caption-str))) ((string= "t" float) (concat (format "\\begin{listing}[%s]\n" - (plist-get info :latex-default-figure-position)) + placement) "%s\n\\end{listing}")) (t "%s"))) (options (plist-get info :latex-minted-options)) @@ -3061,56 +3100,18 @@ holding contextual information." ;;;; Subscript -(defun org-latex--script-size (object info) - "Transcode a subscript or superscript object. -OBJECT is an Org object. INFO is a plist used as a communication -channel." - (let ((output "")) - (org-element-map (org-element-contents object) - (cons 'plain-text org-element-all-objects) - (lambda (obj) - (cl-case (org-element-type obj) - ((entity latex-fragment) - (let ((data (org-trim (org-export-data obj info)))) - (string-match - "\\`\\(?:\\\\[([]\\|\\$+\\)?\\(.*?\\)\\(?:\\\\[])]\\|\\$+\\)?\\'" - data) - (setq output - (concat output - (match-string 1 data) - (let ((blank (org-element-property :post-blank obj))) - (and blank (> blank 0) "\\ ")))))) - (plain-text - (setq output - (format "%s\\text{%s}" output (org-export-data obj info)))) - (otherwise - (setq output - (concat output - (org-export-data obj info) - (let ((blank (org-element-property :post-blank obj))) - (and blank (> blank 0) "\\ "))))))) - info nil org-element-recursive-objects) - ;; Result. Do not wrap into curly brackets if OUTPUT is a single - ;; character. - (concat (if (eq (org-element-type object) 'subscript) "_" "^") - (and (> (length output) 1) "{") - output - (and (> (length output) 1) "}")))) - -(defun org-latex-subscript (subscript _contents info) +(defun org-latex-subscript (_subscript contents _info) "Transcode a SUBSCRIPT object from Org to LaTeX. -CONTENTS is the contents of the object. INFO is a plist holding -contextual information." - (org-latex--script-size subscript info)) +CONTENTS is the contents of the object." + (format "\\textsubscript{%s}" contents)) ;;;; Superscript -(defun org-latex-superscript (superscript _contents info) +(defun org-latex-superscript (_superscript contents _info) "Transcode a SUPERSCRIPT object from Org to LaTeX. -CONTENTS is the contents of the object. INFO is a plist holding -contextual information." - (org-latex--script-size superscript info)) +CONTENTS is the contents of the object." + (format "\\textsuperscript{%s}" contents)) ;;;; Table @@ -3180,6 +3181,56 @@ centered." info) (apply 'concat (nreverse align))))) +(defun org-latex--decorate-table (table attributes caption above? info) + "Decorate TABLE string with caption and float environment. + +ATTRIBUTES is the plist containing is LaTeX attributes. CAPTION +is its caption, as a string or nil. It is located above the +table if ABOVE? is non-nil. INFO is the plist containing current +export parameters. + +Return new environment, as a string." + (let* ((float-environment + (let ((float (plist-get attributes :float))) + (cond ((and (not float) (plist-member attributes :float)) nil) + ((member float '("sidewaystable" "sideways")) "sidewaystable") + ((equal float "multicolumn") "table*") + ((or float (org-string-nw-p caption)) "table") + (t nil)))) + (placement + (or (plist-get attributes :placement) + (format "[%s]" (plist-get info :latex-default-figure-position)))) + (center? (if (plist-member attributes :center) + (plist-get attributes :center) + (plist-get info :latex-tables-centered))) + (fontsize (let ((font (plist-get attributes :font))) + (and font (concat font "\n"))))) + (concat (cond + (float-environment + (concat (format "\\begin{%s}%s\n" float-environment placement) + (if above? caption "") + (when center? "\\centering\n") + fontsize)) + (caption + (concat (and center? "\\begin{center}\n" ) + (if above? caption "") + (cond ((and fontsize center?) fontsize) + (fontsize (concat "{" fontsize)) + (t nil)))) + (center? (concat "\\begin{center}\n" fontsize)) + (fontsize (concat "{" fontsize))) + table + (cond + (float-environment + (concat (if above? "" (concat "\n" caption)) + (format "\n\\end{%s}" float-environment))) + (caption + (concat (if above? "" (concat "\n" caption)) + (and center? "\n\\end{center}") + (and fontsize (not center?) "}"))) + (center? "\n\\end{center}") + (fontsize "}"))))) + (defun org-latex--org-table (table contents info) "Return appropriate LaTeX code for an Org table. @@ -3189,109 +3240,44 @@ channel. This function assumes TABLE has `org' as its `:type' property and `table' as its `:mode' attribute." - (let* ((caption (org-latex--caption/label-string table info)) - (attr (org-export-read-attribute :attr_latex table)) - ;; Determine alignment string. + (let* ((attr (org-export-read-attribute :attr_latex table)) (alignment (org-latex--align-string table info)) - ;; Determine environment for the table: longtable, tabular... (table-env (or (plist-get attr :environment) (plist-get info :latex-default-table-environment))) - ;; If table is a float, determine environment: table, table* - ;; or sidewaystable. - (float-env (unless (member table-env '("longtable" "longtabu")) - (let ((float (plist-get attr :float))) - (cond - ((and (not float) (plist-member attr :float)) nil) - ((or (string= float "sidewaystable") - (string= float "sideways")) "sidewaystable") - ((string= float "multicolumn") "table*") - ((or float - (org-element-property :caption table) - (org-string-nw-p (plist-get attr :caption))) - "table"))))) - ;; Extract others display options. - (fontsize (let ((font (plist-get attr :font))) - (and font (concat font "\n")))) - ;; "tabular" environment doesn't allow to define a width. - (width (and (not (equal table-env "tabular")) (plist-get attr :width))) - (spreadp (plist-get attr :spread)) - (placement - (or (plist-get attr :placement) - (format "[%s]" (plist-get info :latex-default-figure-position)))) - (centerp (if (plist-member attr :center) (plist-get attr :center) - (plist-get info :latex-tables-centered))) - (caption-above-p (org-latex--caption-above-p table info))) - ;; Prepare the final format string for the table. + (width + (let ((w (plist-get attr :width))) + (cond ((not w) "") + ((member table-env '("tabular" "longtable")) "") + ((member table-env '("tabu" "longtabu")) + (format (if (plist-get attr :spread) " spread %s " + " to %s ") + w)) + (t (format "{%s}" w))))) + (caption (org-latex--caption/label-string table info)) + (above? (org-latex--caption-above-p table info))) (cond - ;; Longtable. - ((equal "longtable" table-env) - (concat (and fontsize (concat "{" fontsize)) - (format "\\begin{longtable}{%s}\n" alignment) - (and caption-above-p - (org-string-nw-p caption) - (concat caption "\\\\\n")) - contents - (and (not caption-above-p) - (org-string-nw-p caption) - (concat caption "\\\\\n")) - "\\end{longtable}\n" - (and fontsize "}"))) - ;; Longtabu - ((equal "longtabu" table-env) - (concat (and fontsize (concat "{" fontsize)) - (format "\\begin{longtabu}%s{%s}\n" - (if width - (format " %s %s " - (if spreadp "spread" "to") width) "") - alignment) - (and caption-above-p - (org-string-nw-p caption) - (concat caption "\\\\\n")) - contents - (and (not caption-above-p) - (org-string-nw-p caption) - (concat caption "\\\\\n")) - "\\end{longtabu}\n" - (and fontsize "}"))) - ;; Others. - (t (concat (cond - (float-env - (concat (format "\\begin{%s}%s\n" float-env placement) - (if caption-above-p caption "") - (when centerp "\\centering\n") - fontsize)) - ((and (not float-env) caption) - (concat - (and centerp "\\begin{center}\n" ) - (if caption-above-p caption "") - (cond ((and fontsize centerp) fontsize) - (fontsize (concat "{" fontsize))))) - (centerp (concat "\\begin{center}\n" fontsize)) - (fontsize (concat "{" fontsize))) - (cond ((equal "tabu" table-env) - (format "\\begin{tabu}%s{%s}\n%s\\end{tabu}" - (if width (format - (if spreadp " spread %s " " to %s ") - width) "") - alignment - contents)) - (t (format "\\begin{%s}%s{%s}\n%s\\end{%s}" - table-env - (if width (format "{%s}" width) "") - alignment - contents - table-env))) - (cond - (float-env - (concat (if caption-above-p "" (concat "\n" caption)) - (format "\n\\end{%s}" float-env))) - ((and (not float-env) caption) - (concat - (if caption-above-p "" (concat "\n" caption)) - (and centerp "\n\\end{center}") - (and fontsize (not centerp) "}"))) - (centerp "\n\\end{center}") - (fontsize "}"))))))) + ((member table-env '("longtable" "longtabu")) + (let ((fontsize (let ((font (plist-get attr :font))) + (and font (concat font "\n"))))) + (concat (and fontsize (concat "{" fontsize)) + (format "\\begin{%s}%s{%s}\n" table-env width alignment) + (and above? + (org-string-nw-p caption) + (concat caption "\\\\\n")) + contents + (and (not above?) + (org-string-nw-p caption) + (concat caption "\\\\\n")) + (format "\\end{%s}" table-env) + (and fontsize "}")))) + (t + (let ((output (format "\\begin{%s}%s{%s}\n%s\\end{%s}" + table-env + width + alignment + contents + table-env))) + (org-latex--decorate-table output attr caption above? info)))))) (defun org-latex--table.el-table (table info) "Return appropriate LaTeX code for a table.el table. @@ -3305,18 +3291,20 @@ property." ;; Ensure "*org-export-table*" buffer is empty. (with-current-buffer (get-buffer-create "*org-export-table*") (erase-buffer)) - (let ((output (with-temp-buffer - (insert (org-element-property :value table)) - (goto-char 1) - (re-search-forward "^[ \t]*|[^|]" nil t) - (table-generate-source 'latex "*org-export-table*") - (with-current-buffer "*org-export-table*" - (org-trim (buffer-string)))))) + (let ((output + (replace-regexp-in-string + "^%.*\n" "" ;remove comments + (with-temp-buffer + (save-excursion (insert (org-element-property :value table))) + (re-search-forward "^[ \t]*|[^|]" nil t) + (table-generate-source 'latex "*org-export-table*") + (with-current-buffer "*org-export-table*" + (org-trim (buffer-string)))) + t t))) (kill-buffer (get-buffer "*org-export-table*")) - ;; Remove left out comments. - (while (string-match "^%.*\n" output) - (setq output (replace-match "" t t output))) - (let ((attr (org-export-read-attribute :attr_latex table))) + (let ((attr (org-export-read-attribute :attr_latex table)) + (caption (org-latex--caption/label-string table info)) + (above? (org-latex--caption-above-p table info))) (when (plist-get attr :rmlines) ;; When the "rmlines" attribute is provided, remove all hlines ;; but the one separating heading from the table body. @@ -3325,10 +3313,7 @@ property." (setq pos (string-match "^\\\\hline\n?" output pos))) (cl-incf n) (unless (= n 2) (setq output (replace-match "" nil nil output)))))) - (let ((centerp (if (plist-member attr :center) (plist-get attr :center) - (plist-get info :latex-tables-centered)))) - (if (not centerp) output - (format "\\begin{center}\n%s\n\\end{center}" output)))))) + (org-latex--decorate-table output attr caption above? info)))) (defun org-latex--math-table (table info) "Return appropriate LaTeX code for a matrix. diff --git a/lisp/org/ox-man.el b/lisp/org/ox-man.el index c0b0f7d223b..00698fc21fe 100644 --- a/lisp/org/ox-man.el +++ b/lisp/org/ox-man.el @@ -424,7 +424,7 @@ CONTENTS is nil. INFO is a plist holding contextual information." CONTENTS is nil. INFO is a plist holding contextual information." (org-man--wrap-label fixed-width - (format "\\fC\n%s\\fP" + (format "\\fC\n%s\n\\fP" (org-remove-indentation (org-element-property :value fixed-width))))) diff --git a/lisp/org/ox-md.el b/lisp/org/ox-md.el index fa663db501b..0a9441a1f9b 100644 --- a/lisp/org/ox-md.el +++ b/lisp/org/ox-md.el @@ -175,7 +175,7 @@ channel." value))) -;;;; Example Block, Src Block and export Block +;;;; Example Block, Src Block and Export Block (defun org-md-example-block (example-block _contents info) "Transcode EXAMPLE-BLOCK element into Markdown format. @@ -211,8 +211,7 @@ a communication channel." (tags (and (plist-get info :with-tags) (let ((tag-list (org-export-get-tags headline info))) (and tag-list - (format " :%s:" - (mapconcat 'identity tag-list ":")))))) + (concat " " (org-make-tag-string tag-list)))))) (priority (and (plist-get info :with-priority) (let ((char (org-element-property :priority headline))) @@ -364,9 +363,14 @@ channel." ((string-match-p "\\<headlines\\>" value) (let ((depth (and (string-match "\\<[0-9]+\\>" value) (string-to-number (match-string 0 value)))) - (local? (string-match-p "\\<local\\>" value))) + (scope + (cond + ((string-match ":target +\\(\".+?\"\\|\\S-+\\)" value) ;link + (org-export-resolve-link + (org-strip-quotes (match-string 1 value)) info)) + ((string-match-p "\\<local\\>" value) keyword)))) ;local (org-remove-indentation - (org-md--build-toc info depth keyword local?))))))) + (org-md--build-toc info depth keyword scope))))))) (_ (org-export-with-backend 'html keyword contents info)))) @@ -449,7 +453,7 @@ a communication channel." (t (let* ((raw-path (org-element-property :path link)) (path (cond - ((member type '("http" "https" "ftp" "mailto" "irc")) + ((member type '("http" "https" "ftp" "mailto")) (concat type ":" raw-path)) ((string= type "file") (org-export-file-uri (funcall link-org-files-as-md raw-path))) @@ -551,7 +555,7 @@ a communication channel." ;;;; Template -(defun org-md--build-toc (info &optional n keyword local) +(defun org-md--build-toc (info &optional n _keyword scope) "Return a table of contents. INFO is a plist used as a communication channel. @@ -559,13 +563,10 @@ INFO is a plist used as a communication channel. Optional argument N, when non-nil, is an integer specifying the depth of the table. -Optional argument KEYWORD specifies the TOC keyword, if any, from -which the table of contents generation has been initiated. - -When optional argument LOCAL is non-nil, build a table of -contents according to the current headline." +When optional argument SCOPE is non-nil, build a table of +contents according to the specified element." (concat - (unless local + (unless scope (let ((style (plist-get info :md-headline-style)) (title (org-html--translate "Table of Contents" info))) (org-md--headline-title style 1 title nil))) @@ -575,10 +576,13 @@ contents according to the current headline." (make-string (* 4 (1- (org-export-get-relative-level headline info))) ?\s)) - (number (format "%d." - (org-last - (org-export-get-headline-number headline info)))) - (bullet (concat number (make-string (- 4 (length number)) ?\s))) + (bullet + (if (not (org-export-numbered-headline-p headline info)) "- " + (let ((prefix + (format "%d." (org-last (org-export-get-headline-number + headline info))))) + (concat prefix (make-string (max 1 (- 4 (length prefix))) + ?\s))))) (title (format "[%s](#%s)" (org-export-data-with-backend @@ -589,12 +593,10 @@ contents according to the current headline." (org-export-get-reference headline info)))) (tags (and (plist-get info :with-tags) (not (eq 'not-in-toc (plist-get info :with-tags))) - (let ((tags (org-export-get-tags headline info))) - (and tags - (format ":%s:" - (mapconcat #'identity tags ":"))))))) + (org-make-tag-string + (org-export-get-tags headline info))))) (concat indentation bullet title tags))) - (org-export-collect-headlines info n (and local keyword)) "\n") + (org-export-collect-headlines info n scope) "\n") "\n")) (defun org-md--footnote-formatted (footnote info) diff --git a/lisp/org/ox-odt.el b/lisp/org/ox-odt.el index 999a2b7f5cf..f9c4a93cc8b 100644 --- a/lisp/org/ox-odt.el +++ b/lisp/org/ox-odt.el @@ -27,8 +27,9 @@ (require 'cl-lib) (require 'format-spec) -(require 'ox) (require 'org-compat) +(require 'org-macs) +(require 'ox) (require 'table nil 'noerror) ;;; Define Back-End @@ -147,8 +148,7 @@ Use this to infer values of `org-odt-styles-dir' and `org-odt-schema-dir'.") -(defvar org-odt-data-dir - (expand-file-name "../../etc/" org-odt-lib-dir) +(defvar org-odt-data-dir (expand-file-name "../../etc/" org-odt-lib-dir) "Data directory for ODT exporter. Use this to infer values of `org-odt-styles-dir' and `org-odt-schema-dir'.") @@ -161,25 +161,17 @@ Use this to infer values of `org-odt-styles-dir' and "Regular expressions for special string conversion.") (defconst org-odt-schema-dir-list - (list - (and org-odt-data-dir - (expand-file-name "./schema/" org-odt-data-dir)) ; bail out - (eval-when-compile - (and (boundp 'org-odt-data-dir) org-odt-data-dir ; see make install - (expand-file-name "./schema/" org-odt-data-dir)))) + (list (expand-file-name "./schema/" org-odt-data-dir)) "List of directories to search for OpenDocument schema files. -Use this list to set the default value of -`org-odt-schema-dir'. The entries in this list are -populated heuristically based on the values of `org-odt-lib-dir' -and `org-odt-data-dir'.") +Use this list to set the default value of `org-odt-schema-dir'. +The entries in this list are populated heuristically based on the +values of `org-odt-lib-dir' and `org-odt-data-dir'.") (defconst org-odt-styles-dir-list (list (and org-odt-data-dir (expand-file-name "./styles/" org-odt-data-dir)) ; bail out - (eval-when-compile - (and (boundp 'org-odt-data-dir) org-odt-data-dir ; see make install - (expand-file-name "./styles/" org-odt-data-dir))) + (expand-file-name "./styles/" org-odt-data-dir) (expand-file-name "../etc/styles/" org-odt-lib-dir) ; git (expand-file-name "./etc/styles/" org-odt-lib-dir) ; elpa (expand-file-name "./org/" data-directory) ; system @@ -822,7 +814,7 @@ form (TABLE-STYLE-NAME TABLE-TEMPLATE-NAME TABLE-CELL-OPTIONS). TABLE-STYLE-NAME is the style associated with the table through \"#+ATTR_ODT: :style TABLE-STYLE-NAME\" line. -TABLE-TEMPLATE-NAME is a set of - upto 9 - automatic +TABLE-TEMPLATE-NAME is a set of - up to 9 - automatic TABLE-CELL-STYLE-NAMEs and PARAGRAPH-STYLE-NAMEs (as defined below) that is included in `org-odt-content-template-file'. @@ -1357,17 +1349,18 @@ original parsed data. INFO is a plist holding export options." ;; Update styles file. ;; Copy styles.xml. Also dump htmlfontify styles, if there is any. ;; Write styles file. - (let* ((styles-file (plist-get info :odt-styles-file)) - (styles-file (and (org-string-nw-p styles-file) - (read (org-trim styles-file)))) - ;; Non-availability of styles.xml is not a critical - ;; error. For now, throw an error. - (styles-file (or styles-file - (plist-get info :odt-styles-file) - (expand-file-name "OrgOdtStyles.xml" - org-odt-styles-dir) - (error "org-odt: Missing styles file?")))) + (let* ((styles-file + (pcase (plist-get info :odt-styles-file) + (`nil (expand-file-name "OrgOdtStyles.xml" org-odt-styles-dir)) + ((and s (pred (string-match-p "\\`(.*)\\'"))) + (condition-case nil + (read s) + (error (user-error "Invalid styles file specification: %S" s)))) + (filename (org-strip-quotes filename))))) (cond + ;; Non-availability of styles.xml is not a critical error. For + ;; now, throw an error. + ((null styles-file) (error "Missing styles file")) ((listp styles-file) (let ((archive (nth 0 styles-file)) (members (nth 1 styles-file))) @@ -1377,7 +1370,7 @@ original parsed data. INFO is a plist holding export options." (let* ((image-type (file-name-extension member)) (media-type (format "image/%s" image-type))) (org-odt-create-manifest-file-entry media-type member)))))) - ((and (stringp styles-file) (file-exists-p styles-file)) + ((file-exists-p styles-file) (let ((styles-file-type (file-name-extension styles-file))) (cond ((string= styles-file-type "xml") @@ -1421,7 +1414,7 @@ original parsed data. INFO is a plist holding export options." ;; the resulting odt file. (setq-local backup-inhibited t) - ;; Outline numbering is retained only upto LEVEL. + ;; Outline numbering is retained only up to LEVEL. ;; To disable outline numbering pass a LEVEL of 0. (goto-char (point-min)) @@ -1967,10 +1960,12 @@ contextual information." CONTENTS holds the contents of the item. INFO is a plist holding contextual information." (let* ((plain-list (org-export-get-parent item)) + (count (org-element-property :counter item)) (type (org-element-property :type plain-list))) (unless (memq type '(ordered unordered descriptive-1 descriptive-2)) (error "Unknown list type: %S" type)) - (format "\n<text:list-item>\n%s\n%s" + (format "\n<text:list-item%s>\n%s\n%s" + (if count (format " text:start-value=\"%s\"" count) "") contents (if (org-element-map item 'table #'identity info 'first-match) "</text:list-header>" @@ -1996,8 +1991,13 @@ information." (let ((depth (or (and (string-match "\\<[0-9]+\\>" value) (string-to-number (match-string 0 value))) (plist-get info :headline-levels))) - (localp (string-match-p "\\<local\\>" value))) - (org-odt-toc depth info (and localp keyword)))) + (scope + (cond + ((string-match ":target +\\(\".+?\"\\|\\S-+\\)" value) ;link + (org-export-resolve-link + (org-strip-quotes (match-string 1 value)) info)) + ((string-match-p "\\<local\\>" value) keyword)))) ;local + (org-odt-toc depth info scope))) ((string-match-p "tables\\|figures\\|listings" value) ;; FIXME (ignore)))))))) @@ -3144,7 +3144,7 @@ and prefix with \"OrgSrc\". For example, (code-info (org-export-unravel-code element)) (code (car code-info)) (refs (cdr code-info)) - ;; Does the src block contain labels? + ;; Does the source block contain labels? (retain-labels (org-element-property :retain-labels element)) ;; Does it have line numbers? (num-start (org-export-get-loc element info))) @@ -3241,7 +3241,7 @@ styles congruent with the ODF-1.2 specification." (when style-spec ;; LibreOffice - particularly the Writer - honors neither table ;; templates nor custom table-cell styles. Inorder to retain - ;; inter-operability with LibreOffice, only automatic styles are + ;; interoperability with LibreOffice, only automatic styles are ;; used for styling of table-cells. The current implementation is ;; congruent with ODF-1.2 specification and hence is ;; future-compatible. diff --git a/lisp/org/ox-org.el b/lisp/org/ox-org.el index ca102872d03..0e7f977f0f3 100644 --- a/lisp/org/ox-org.el +++ b/lisp/org/ox-org.el @@ -96,7 +96,7 @@ setting of `org-html-htmlize-output-type' is `css'." (table-cell . org-org-identity) (table-row . org-org-identity) (target . org-org-identity) - (timestamp . org-org-identity) + (timestamp . org-org-timestamp) (underline . org-org-identity) (verbatim . org-org-identity) (verse-block . org-org-identity)) @@ -206,6 +206,10 @@ as a communication channel." (format "#+CREATOR: %s\n" (plist-get info :creator))) contents)) +(defun org-org-timestamp (timestamp _contents _info) + "Transcode a TIMESTAMP object to custom format or back into Org syntax." + (org-timestamp-translate timestamp)) + (defun org-org-section (section contents info) "Transcode SECTION element back into Org syntax. CONTENTS is the contents of the section. INFO is a plist used as @@ -270,7 +274,7 @@ non-nil." ;;;###autoload (defun org-org-export-to-org (&optional async subtreep visible-only body-only ext-plist) - "Export current buffer to an org file. + "Export current buffer to an Org file. If narrowing is active in the current buffer, only export its narrowed part. @@ -303,7 +307,7 @@ Return output file name." ;;;###autoload (defun org-org-publish-to-org (plist filename pub-dir) - "Publish an org file to org. + "Publish an Org file to Org. FILENAME is the filename of the Org file to be published. PLIST is the property list for the given project. PUB-DIR is the @@ -324,8 +328,7 @@ Return output file name." newbuf) (with-current-buffer work-buffer (org-font-lock-ensure) - (outline-show-all) - (org-show-block-all) + (org-show-all) (setq newbuf (htmlize-buffer))) (with-current-buffer newbuf (when org-org-htmlized-css-url diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el index 39547382b27..28d063e4b4b 100644 --- a/lisp/org/ox-publish.el +++ b/lisp/org/ox-publish.el @@ -867,8 +867,7 @@ PROPERTY, i.e. \"behavior\" parameter from `org-export-options-alist'." (org-no-properties (org-element-interpret-data parsed-title)) (file-name-nondirectory (file-name-sans-extension file))))) - (org-publish-cache-set-file-property file :title title) - title)))) + (org-publish-cache-set-file-property file :title title))))) (defun org-publish-find-date (file project) "Find the date of FILE in PROJECT. @@ -877,20 +876,23 @@ If FILE is an Org file and provides a DATE keyword use it. In any other case use the file system's modification time. Return time in `current-time' format." (let ((file (org-publish--expand-file-name file project))) - (if (file-directory-p file) (file-attribute-modification-time - (file-attributes file)) - (let ((date (org-publish-find-property file :date project))) - ;; DATE is a secondary string. If it contains a time-stamp, - ;; convert it to internal format. Otherwise, use FILE - ;; modification time. - (cond ((let ((ts (and (consp date) (assq 'timestamp date)))) - (and ts - (let ((value (org-element-interpret-data ts))) - (and (org-string-nw-p value) - (org-time-string-to-time value)))))) - ((file-exists-p file) (file-attribute-modification-time - (file-attributes file))) - (t (error "No such file: \"%s\"" file))))))) + (or (org-publish-cache-get-file-property file :date nil t) + (org-publish-cache-set-file-property + file :date + (if (file-directory-p file) + (file-attribute-modification-time (file-attributes file)) + (let ((date (org-publish-find-property file :date project))) + ;; DATE is a secondary string. If it contains + ;; a time-stamp, convert it to internal format. + ;; Otherwise, use FILE modification time. + (cond ((let ((ts (and (consp date) (assq 'timestamp date)))) + (and ts + (let ((value (org-element-interpret-data ts))) + (and (org-string-nw-p value) + (org-time-string-to-time value)))))) + ((file-exists-p file) + (file-attribute-modification-time (file-attributes file))) + (t (error "No such file: \"%s\"" file))))))))) (defun org-publish-sitemap-default-entry (entry style project) "Default format for site map ENTRY, as a string. @@ -1145,7 +1147,7 @@ This function is meant to be used as a final output filter. See ;; Return output unchanged. output) -(defun org-publish-resolve-external-link (search file) +(defun org-publish-resolve-external-link (search file &optional prefer-custom) "Return reference for element matching string SEARCH in FILE. Return value is an internal reference, as a string. @@ -1153,23 +1155,39 @@ Return value is an internal reference, as a string. This function allows resolving external links with a search option, e.g., - [[file.org::*heading][description]] - [[file.org::#custom-id][description]] - [[file.org::fuzzy][description]] + [[file:file.org::*heading][description]] + [[file:file.org::#custom-id][description]] + [[file:file.org::fuzzy][description]] + +When PREFER-CUSTOM is non-nil, and SEARCH targets a headline in +FILE, return its custom ID, if any. It only makes sense to use this if export back-end builds references with `org-export-get-reference'." - (if (not org-publish-cache) - (progn - (message "Reference %S in file %S cannot be resolved without publishing" - search - file) - "MissingReference") + (cond + ((and prefer-custom + (if (string-prefix-p "#" search) + (substring search 1) + (with-current-buffer (find-file-noselect file) + (org-with-point-at 1 + (let ((org-link-search-must-match-exact-headline t)) + (condition-case err + (org-link-search search nil t) + (error + (signal 'org-link-broken (cdr err))))) + (and (org-at-heading-p) + (org-string-nw-p (org-entry-get (point) "CUSTOM_ID")))))))) + ((not org-publish-cache) + (progn + (message "Reference %S in file %S cannot be resolved without publishing" + search + file) + "MissingReference")) + (t (let* ((filename (file-truename file)) (crossrefs (org-publish-cache-get-file-property filename :crossrefs nil t)) - (cells - (org-export-string-to-search-cell (org-link-unescape search)))) + (cells (org-export-string-to-search-cell search))) (or ;; Look for reference associated to search cells triggered by ;; LINK. It can match when targeted file has been published @@ -1182,7 +1200,7 @@ references with `org-export-get-reference'." (let ((new (org-export-new-reference crossrefs))) (dolist (cell cells) (push (cons cell new) crossrefs)) (org-publish-cache-set-file-property filename :crossrefs crossrefs) - (org-export-format-reference new)))))) + (org-export-format-reference new))))))) (defun org-publish-file-relative-name (filename info) "Convert FILENAME to be relative to current project's base directory. @@ -1283,8 +1301,8 @@ the file including them will be republished as well." (let* ((value (org-element-property :value element)) (filename (and (string-match "\\`\\(\".+?\"\\|\\S-+\\)" value) - (let ((m (org-unbracket-string - "\"" "\"" (match-string 1 value)))) + (let ((m (org-strip-quotes + (match-string 1 value)))) ;; Ignore search suffix. (if (string-match "::.*?\\'" m) (substring m 0 (match-beginning 0)) @@ -1296,8 +1314,9 @@ the file including them will be republished as well." (unless visiting (kill-buffer buf))))) (or (null pstamp) (let ((ctime (org-publish-cache-ctime-of-src filename))) - (or (< pstamp ctime) - (cl-some (lambda (ct) (< ctime ct)) included-files-ctime)))))) + (or (time-less-p pstamp ctime) + (cl-some (lambda (ct) (time-less-p ctime ct)) + included-files-ctime)))))) (defun org-publish-cache-set-file-property (filename property value &optional project-name) @@ -1305,7 +1324,7 @@ the file including them will be republished as well." Use cache file of PROJECT-NAME. If the entry does not exist, it will be created. Return VALUE." ;; Evtl. load the requested cache file: - (if project-name (org-publish-initialize-cache project-name)) + (when project-name (org-publish-initialize-cache project-name)) (let ((pl (org-publish-cache-get filename))) (if pl (progn (plist-put pl property value) value) (org-publish-cache-get-file-property @@ -1347,8 +1366,8 @@ does not exist." (let ((attr (file-attributes (expand-file-name (or (file-symlink-p file) file) (file-name-directory file))))) - (if (not attr) (error "No such file: \"%s\"" file) - (time-convert (file-attribute-modification-time attr) 'integer)))) + (if attr (file-attribute-modification-time attr) + (error "No such file: %S" file)))) (provide 'ox-publish) diff --git a/lisp/org/ox-texinfo.el b/lisp/org/ox-texinfo.el index 468fc584daa..5e7463256fb 100644 --- a/lisp/org/ox-texinfo.el +++ b/lisp/org/ox-texinfo.el @@ -147,10 +147,12 @@ If nil it will default to `buffer-file-coding-system'." (defcustom org-texinfo-classes '(("info" "@documentencoding AUTO\n@documentlanguage AUTO" - ("@chapter %s" "@unnumbered %s" "@appendix %s") - ("@section %s" "@unnumberedsec %s" "@appendixsec %s") - ("@subsection %s" "@unnumberedsubsec %s" "@appendixsubsec %s") - ("@subsubsection %s" "@unnumberedsubsubsec %s" "@appendixsubsubsec %s"))) + ("@chapter %s" "@unnumbered %s" "@chapheading %s" "@appendix %s") + ("@section %s" "@unnumberedsec %s" "@heading %s" "@appendixsec %s") + ("@subsection %s" "@unnumberedsubsec %s" "@subheading %s" + "@appendixsubsec %s") + ("@subsubsection %s" "@unnumberedsubsubsec %s" "@subsubheading %s" + "@appendixsubsubsec %s"))) "Alist of Texinfo classes and associated header and structure. If #+TEXINFO_CLASS is set in the buffer, use its value and the associated information. Here is the structure of a class @@ -158,8 +160,8 @@ definition: (class-name header-string - (numbered-1 unnumbered-1 appendix-1) - (numbered-2 unnumbered-2 appendix-2) + (numbered-1 unnumbered-1 unnumbered-no-toc-1 appendix-1) + (numbered-2 unnumbered-2 unnumbered-no-toc-2 appendix-2) ...) @@ -193,17 +195,18 @@ following the header string. For each sectioning level, a number of strings is specified. A %s formatter is mandatory in each section string and will be replaced by the title of the section." :group 'org-export-texinfo - :version "26.1" - :package-version '(Org . "9.1") + :version "27.1" + :package-version '(Org . "9.2") :type '(repeat (list (string :tag "Texinfo class") (string :tag "Texinfo header") (repeat :tag "Levels" :inline t (choice (list :tag "Heading" - (string :tag " numbered") - (string :tag "unnumbered") - (string :tag " appendix"))))))) + (string :tag " numbered") + (string :tag " unnumbered") + (string :tag "unnumbered-no-toc") + (string :tag " appendix"))))))) ;;;; Headline @@ -264,7 +267,7 @@ be placed after the end of the title." :group 'org-export-texinfo :type 'boolean) -(defcustom org-texinfo-table-scientific-notation "%s\\,(%s)" +(defcustom org-texinfo-table-scientific-notation nil "Format string to display numbers in scientific notation. The format should have \"%s\" twice, for mantissa and exponent @@ -463,22 +466,40 @@ INFO is a plist used as a communication channel. See (defun org-texinfo--get-node (datum info) "Return node or anchor associated to DATUM. -DATUM is an element or object. INFO is a plist used as -a communication channel. The function guarantees the node or -anchor name is unique." +DATUM is a headline, a radio-target or a target. INFO is a plist +used as a communication channel. The function guarantees the +node or anchor name is unique." (let ((cache (plist-get info :texinfo-node-cache))) (or (cdr (assq datum cache)) (let* ((salt 0) (basename (org-texinfo--sanitize-node - (if (eq (org-element-type datum) 'headline) - (org-texinfo--sanitize-title - (org-export-get-alt-title datum info) info) - (org-export-get-reference datum info)))) + (pcase (org-element-type datum) + (`headline + (org-texinfo--sanitize-title + (org-export-get-alt-title datum info) info)) + (`radio-target + (org-export-data (org-element-contents datum) info)) + (`target + (org-element-property :value datum)) + (_ + (or (org-element-property :name datum) + (org-export-get-reference datum info)))))) (name basename)) + ;; Org exports deeper elements before their parents. If two + ;; node names collide -- e.g., they have the same title -- + ;; within the same hierarchy, the second one would get the + ;; shorter node name. This is counter-intuitive. + ;; Consequently, we ensure that every parent headline get + ;; its node beforehand. As a recursive operation, this + ;; achieves the desired effect. + (let ((parent (org-element-lineage datum '(headline)))) + (when (and parent (not (assq parent cache))) + (org-texinfo--get-node parent info) + (setq cache (plist-get info :texinfo-node-cache)))) ;; Ensure NAME is unique and not reserved node name "Top". (while (or (equal name "Top") (rassoc name cache)) - (setq name (concat basename (format " %d" (cl-incf salt))))) + (setq name (concat basename (format " (%d)" (cl-incf salt))))) (plist-put info :texinfo-node-cache (cons (cons datum name) cache)) name)))) @@ -500,18 +521,7 @@ periods, commas and colons." TITLE is a string or a secondary string. INFO is the current export state, as a plist." (org-export-data-with-backend - title - (org-export-create-backend - :parent 'texinfo - :transcoders '((footnote-reference . ignore) - (link . (lambda (l c i) - (or c - (org-export-data - (org-element-property :raw-link l) - i)))) - (radio-target . (lambda (_r c _i) c)) - (target . ignore))) - info)) + title (org-export-toc-entry-backend 'texinfo) info)) (defun org-texinfo--sanitize-content (text) "Escape special characters in string TEXT. @@ -526,29 +536,13 @@ float, as a string. CAPTION and SHORT are, respectively, the caption and shortcaption used for the float, as secondary strings (e.g., returned by `org-export-get-caption')." (let* ((backend - (org-export-create-backend - :parent 'texinfo - :transcoders '((link . (lambda (l c i) - (or c - (org-export-data - (org-element-property :raw-link l) - i)))) - (radio-target . (lambda (_r c _i) c)) - (target . ignore)))) + (org-export-toc-entry-backend 'texinfo + (cons 'footnote-reference + (lambda (f c i) (org-export-with-backend 'texinfo f c i))))) (short-backend - (org-export-create-backend - :parent 'texinfo - :transcoders - '((footnote-reference . ignore) - (inline-src-block . ignore) - (link . (lambda (l c i) - (or c - (org-export-data - (org-element-property :raw-link l) - i)))) - (radio-target . (lambda (_r c _i) c)) - (target . ignore) - (verbatim . ignore)))) + (org-export-toc-entry-backend 'texinfo + '(inline-src-block . ignore) + '(verbatim . ignore))) (short-str (if (and short caption) (format "@shortcaption{%s}\n" @@ -582,7 +576,7 @@ holding export options." (concat "\\input texinfo @c -*- texinfo -*-\n" "@c %**start of header\n" - (let ((file (or (plist-get info :texinfo-filename) + (let ((file (or (org-strip-quotes (plist-get info :texinfo-filename)) (let ((f (plist-get info :output-file))) (and f (concat (file-name-sans-extension f) ".info")))))) (and file (format "@setfilename %s\n" file))) @@ -712,7 +706,7 @@ contextual information." "Transcode a CENTER-BLOCK element from Org to Texinfo. CONTENTS holds the contents of the block. INFO is a plist used as a communication channel." - contents) + (replace-regexp-in-string "\\(^\\).*?\\S-" "@center " contents nil nil 1)) ;;;; Clock @@ -831,7 +825,7 @@ CONTENTS is nil. INFO is a plist holding contextual information." (defun org-texinfo-fixed-width (fixed-width _contents _info) "Transcode a FIXED-WIDTH element from Org to Texinfo. CONTENTS is nil. INFO is a plist holding contextual information." - (format "@example\n%s@end example" + (format "@example\n%s\n@end example" (org-remove-indentation (org-texinfo--sanitize-content (org-element-property :value fixed-width))))) @@ -849,84 +843,81 @@ plist holding contextual information." ;;;; Headline -(defun org-texinfo--structuring-command (headline info) - "Return Texinfo structuring command string for HEADLINE element. -Return nil if HEADLINE is to be ignored, `plain-list' if it -should be exported as a plain-list item. INFO is a plist holding -contextual information." - (cond - ((org-element-property :footnote-section-p headline) nil) - ((org-not-nil (org-export-get-node-property :COPYING headline t)) nil) - ((org-export-low-level-p headline info) 'plain-list) - (t - (let ((class (plist-get info :texinfo-class))) - (pcase (assoc class (plist-get info :texinfo-classes)) - (`(,_ ,_ . ,sections) - (pcase (nth (1- (org-export-get-relative-level headline info)) - sections) - (`(,numbered ,unnumbered ,appendix) - (cond - ((org-not-nil (org-export-get-node-property :APPENDIX headline t)) - appendix) - ((org-not-nil (org-export-get-node-property :INDEX headline t)) - unnumbered) - ((org-export-numbered-headline-p headline info) numbered) - (t unnumbered))) - (`nil 'plain-list) - (_ (user-error "Invalid Texinfo class specification: %S" class)))) - (_ (user-error "Invalid Texinfo class specification: %S" class))))))) - (defun org-texinfo-headline (headline contents info) "Transcode a HEADLINE element from Org to Texinfo. CONTENTS holds the contents of the headline. INFO is a plist holding contextual information." - (let ((section-fmt (org-texinfo--structuring-command headline info))) - (when section-fmt - (let* ((todo - (and (plist-get info :with-todo-keywords) - (let ((todo (org-element-property :todo-keyword headline))) - (and todo (org-export-data todo info))))) - (todo-type (and todo (org-element-property :todo-type headline))) - (tags (and (plist-get info :with-tags) - (org-export-get-tags headline info))) - (priority (and (plist-get info :with-priority) - (org-element-property :priority headline))) - (text (org-texinfo--sanitize-title - (org-element-property :title headline) info)) - (full-text - (funcall (plist-get info :texinfo-format-headline-function) - todo todo-type priority text tags)) - (contents - (concat "\n" - (if (org-string-nw-p contents) - (concat "\n" contents) - "") - (let ((index (org-element-property :INDEX headline))) - (and (member index '("cp" "fn" "ky" "pg" "tp" "vr")) - (format "\n@printindex %s\n" index)))))) - (cond - ((eq section-fmt 'plain-list) - (let ((numbered? (org-export-numbered-headline-p headline info))) - (concat (and (org-export-first-sibling-p headline info) - (format "@%s\n" (if numbered? 'enumerate 'itemize))) - "@item\n" full-text "\n" - contents - (if (org-export-last-sibling-p headline info) - (format "@end %s" (if numbered? 'enumerate 'itemize)) - "\n")))) - (t - (concat (format "@node %s\n" (org-texinfo--get-node headline info)) - (format section-fmt full-text) - contents))))))) + (cond + ((org-element-property :footnote-section-p headline) nil) + ((org-not-nil (org-export-get-node-property :COPYING headline t)) nil) + (t + (let* ((index (let ((i (org-export-get-node-property :INDEX headline t))) + (and (member i '("cp" "fn" "ky" "pg" "tp" "vr")) i))) + (numbered? (org-export-numbered-headline-p headline info)) + (notoc? (org-export-excluded-from-toc-p headline info)) + (command + (and + (not (org-export-low-level-p headline info)) + (let ((class (plist-get info :texinfo-class))) + (pcase (assoc class (plist-get info :texinfo-classes)) + (`(,_ ,_ . ,sections) + (pcase (nth (1- (org-export-get-relative-level headline info)) + sections) + (`(,numbered ,unnumbered ,unnumbered-no-toc ,appendix) + (cond + ((org-not-nil + (org-export-get-node-property :APPENDIX headline t)) + appendix) + (numbered? numbered) + (index unnumbered) + (notoc? unnumbered-no-toc) + (t unnumbered))) + (`nil nil) + (_ (user-error "Invalid Texinfo class specification: %S" + class)))) + (_ (user-error "Unknown Texinfo class: %S" class)))))) + (todo + (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + (text (org-texinfo--sanitize-title + (org-element-property :title headline) info)) + (full-text + (funcall (plist-get info :texinfo-format-headline-function) + todo todo-type priority text tags)) + (contents + (concat "\n" + (if (org-string-nw-p contents) (concat "\n" contents) "") + (and index (format "\n@printindex %s\n" index))))) + (if (not command) + (concat (and (org-export-first-sibling-p headline info) + (format "@%s\n" (if numbered? 'enumerate 'itemize))) + "@item\n" full-text "\n" + contents + (if (org-export-last-sibling-p headline info) + (format "@end %s" (if numbered? 'enumerate 'itemize)) + "\n")) + (concat + ;; Even if HEADLINE is using @subheading and al., leave an + ;; anchor so cross-references in the Org document still work. + (format (if notoc? "@anchor{%s}\n" "@node %s\n") + (org-texinfo--get-node headline info)) + (format command full-text) + contents)))))) (defun org-texinfo-format-headline-default-function (todo _todo-type priority text tags) "Default format function for a headline. See `org-texinfo-format-headline-function' for details." - (concat (when todo (format "@strong{%s} " todo)) - (when priority (format "@emph{#%s} " priority)) + (concat (and todo (format "@strong{%s} " todo)) + (and priority (format "@emph{#%s} " priority)) text - (when tags (format " :%s:" (mapconcat 'identity tags ":"))))) + (and tags (concat " " (org-make-tag-string tags))))) ;;;; Inline Src Block @@ -964,7 +955,7 @@ See `org-texinfo-format-inlinetask-function' for details." (concat (when todo (format "@strong{%s} " todo)) (when priority (format "#%c " priority)) title - (when tags (format ":%s:" (mapconcat #'identity tags ":")))))) + (when tags (org-make-tag-string tags))))) (format "@center %s\n\n%s\n" full-title contents))) ;;;; Italic @@ -1262,13 +1253,23 @@ contextual information." (if (string-prefix-p "@" i) i (concat "@" i)))) (table-type (plist-get attr :table-type)) (type (org-element-property :type plain-list)) + (enum + (cond ((not (eq type 'ordered)) nil) + ((plist-member attr :enum) (plist-get attr :enum)) + (t + ;; Texinfo only supports initial counters, i.e., it + ;; cannot change the numbering mid-list. + (let ((first-item (car (org-element-contents plain-list)))) + (org-element-property :counter first-item))))) (list-type (cond ((eq type 'ordered) "enumerate") ((eq type 'unordered) "itemize") ((member table-type '("ftable" "vtable")) table-type) (t "table")))) (format "@%s\n%s@end %s" - (if (eq type 'descriptive) (concat list-type " " indic) list-type) + (cond ((eq type 'descriptive) (concat list-type " " indic)) + (enum (format "%s %s" list-type enum)) + (t list-type)) contents list-type))) @@ -1298,8 +1299,13 @@ contextual information." (when (plist-get info :preserve-breaks) (setq output (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " @*\n" output))) - ;; Return value. - output)) + ;; Reverse sentence ending. A sentence can end with a capital + ;; letter. Use non-breaking space if it shouldn't. + (let ((case-fold-search nil)) + (replace-regexp-in-string + "[A-Z]\\([.?!]\\)\\(?:[])]\\|'\\{1,2\\}\\)?\\(?: \\|$\\)" + "@\\1" + output nil nil 1)))) ;;;; Planning @@ -1349,11 +1355,12 @@ holding contextual information." "Transcode a QUOTE-BLOCK element from Org to Texinfo. CONTENTS holds the contents of the block. INFO is a plist holding contextual information." - (let* ((title (org-element-property :name quote-block)) - (start-quote (concat "@quotation" - (if title - (format " %s" title))))) - (format "%s\n%s@end quotation" start-quote contents))) + (let ((tag (org-export-read-attribute :attr_texinfo quote-block :tag)) + (author (org-export-read-attribute :attr_texinfo quote-block :author))) + (format "@quotation%s\n%s%s\n@end quotation" + (if tag (concat " " tag) "") + contents + (if author (concat "\n@author " author) "")))) ;;;; Radio Target @@ -1372,9 +1379,12 @@ contextual information." CONTENTS holds the contents of the section. INFO is a plist holding contextual information." (let ((parent (org-export-get-parent-headline section))) - (when parent ;ignore very first section + (when parent ;first section is handled in `org-texinfo-template' (org-trim - (concat contents "\n" (org-texinfo-make-menu parent info)))))) + (concat contents + "\n" + (and (not (org-export-excluded-from-toc-p parent info)) + (org-texinfo-make-menu parent info))))))) ;;;; Special Block diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 0ae1e45f036..5b4134ecca2 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -73,6 +73,7 @@ (require 'cl-lib) (require 'ob-exp) +(require 'ol) (require 'org-element) (require 'org-macro) (require 'tabulated-list) @@ -1499,7 +1500,7 @@ Assume buffer is in Org mode. Narrowing, if any, is ignored." (cond ;; Options in `org-export-special-keywords'. ((equal key "SETUPFILE") - (let* ((uri (org-unbracket-string "\"" "\"" (org-trim val))) + (let* ((uri (org-strip-quotes (org-trim val))) (uri-is-url (org-file-url-p uri)) (uri (if uri-is-url uri @@ -1650,7 +1651,7 @@ an alist where associations are (VARIABLE-NAME VALUE)." "BIND") (push (read (format "(%s)" val)) alist) ;; Enter setup file. - (let* ((uri (org-unbracket-string "\"" "\"" val)) + (let* ((uri (org-strip-quotes val)) (uri-is-url (org-file-url-p uri)) (uri (if uri-is-url uri @@ -2007,17 +2008,18 @@ Return a string." ;; normalized first. (org-element-normalize-contents data - ;; When normalizing contents of the - ;; first paragraph in an item or - ;; a footnote definition, ignore - ;; first line's indentation: there is - ;; none and it might be misleading. - (when (eq type 'paragraph) - (and - (eq (car (org-element-contents parent)) - data) - (memq (org-element-type parent) - '(footnote-definition item))))))) + ;; When normalizing first paragraph + ;; of an item or + ;; a footnote-definition, ignore + ;; first line's indentation. + (and + (eq type 'paragraph) + (memq (org-element-type parent) + '(footnote-definition item)) + (eq (car (org-element-contents parent)) + data) + (eq (org-element-property :pre-blank parent) + 0))))) ""))) (broken-link-handler (funcall transcoder data @@ -2672,10 +2674,7 @@ The function assumes BUFFER's major mode is `org-mode'." (quote ,val)) vars)))))) ;; Whole buffer contents. - (insert - ,(org-with-wide-buffer - (buffer-substring-no-properties - (point-min) (point-max)))) + (insert ,(org-with-wide-buffer (buffer-string))) ;; Narrowing. ,(if (org-region-active-p) `(narrow-to-region ,(region-beginning) ,(region-end)) @@ -2921,56 +2920,47 @@ returned by the function." '(entity bold italic latex-environment latex-fragment strike-through subscript superscript underline) (lambda (datum) - (let ((new - (cl-case (org-element-type datum) - ;; ... entities... - (entity - (and (not (plist-get info :with-entities)) - (list (concat - (org-export-expand datum nil) - (make-string - (or (org-element-property :post-blank datum) 0) - ?\s))))) - ;; ... emphasis... - ((bold italic strike-through underline) - (and (not (plist-get info :with-emphasize)) - (let ((marker (cl-case (org-element-type datum) - (bold "*") - (italic "/") - (strike-through "+") - (underline "_")))) - (append - (list marker) - (org-element-contents datum) - (list (concat - marker - (make-string - (or (org-element-property :post-blank datum) - 0) - ?\s))))))) - ;; ... LaTeX environments and fragments... - ((latex-environment latex-fragment) - (and (eq (plist-get info :with-latex) 'verbatim) - (list (org-export-expand datum nil)))) - ;; ... sub/superscripts... - ((subscript superscript) - (let ((sub/super-p (plist-get info :with-sub-superscript)) - (bracketp (org-element-property :use-brackets-p datum))) - (and (or (not sub/super-p) - (and (eq sub/super-p '{}) (not bracketp))) - (append - (list (concat - (if (eq (org-element-type datum) 'subscript) - "_" - "^") - (and bracketp "{"))) - (org-element-contents datum) - (list (concat - (and bracketp "}") - (and (org-element-property :post-blank datum) - (make-string - (org-element-property :post-blank datum) - ?\s))))))))))) + (let* ((type (org-element-type datum)) + (post-blank + (pcase (org-element-property :post-blank datum) + (`nil nil) + (n (make-string n (if (eq type 'latex-environment) ?\n ?\s))))) + (new + (cl-case type + ;; ... entities... + (entity + (and (not (plist-get info :with-entities)) + (list (concat (org-export-expand datum nil) + post-blank)))) + ;; ... emphasis... + ((bold italic strike-through underline) + (and (not (plist-get info :with-emphasize)) + (let ((marker (cl-case type + (bold "*") + (italic "/") + (strike-through "+") + (underline "_")))) + (append + (list marker) + (org-element-contents datum) + (list (concat marker post-blank)))))) + ;; ... LaTeX environments and fragments... + ((latex-environment latex-fragment) + (and (eq (plist-get info :with-latex) 'verbatim) + (list (concat (org-export-expand datum nil) + post-blank)))) + ;; ... sub/superscripts... + ((subscript superscript) + (let ((sub/super-p (plist-get info :with-sub-superscript)) + (bracketp (org-element-property :use-brackets-p datum))) + (and (or (not sub/super-p) + (and (eq sub/super-p '{}) (not bracketp))) + (append + (list (concat (if (eq type 'subscript) "_" "^") + (and bracketp "{"))) + (org-element-contents datum) + (list (concat (and bracketp "}") + post-blank))))))))) (when new ;; Splice NEW at DATUM location in parse tree. (dolist (e new (org-element-extract-element datum)) @@ -3042,20 +3032,23 @@ Return code as a string." ;; Run first hook with current back-end's name as argument. (run-hook-with-args 'org-export-before-processing-hook (org-export-backend-name backend)) - ;; Include files, delete comments and expand macros. (org-export-expand-include-keyword) (org-export--delete-comment-trees) (org-macro-initialize-templates) - (org-macro-replace-all - (append org-macro-templates org-export-global-macros) - nil parsed-keywords) - ;; Refresh buffer properties and radio targets after - ;; potentially invasive previous changes. Likewise, do it - ;; again after executing Babel code. + (org-macro-replace-all (append org-macro-templates + org-export-global-macros) + parsed-keywords) + ;; Refresh buffer properties and radio targets after previous + ;; potentially invasive changes. (org-set-regexps-and-options) (org-update-radio-target-regexp) + ;; Possibly execute Babel code. Re-run a macro expansion + ;; specifically for {{{results}}} since inline source blocks + ;; may have generated some more. Refresh buffer properties + ;; and radio targets another time. (when org-export-use-babel (org-babel-exp-process-buffer) + (org-macro-replace-all '(("results" . "$1")) parsed-keywords) (org-set-regexps-and-options) (org-update-radio-target-regexp)) ;; Run last hook with current back-end's name as argument. @@ -3090,29 +3083,6 @@ Return code as a string." (dolist (filter (plist-get info :filter-options)) (let ((result (funcall filter info backend-name))) (when result (setq info result))))) - ;; Expand export-specific set of macros: {{{author}}}, - ;; {{{date(FORMAT)}}}, {{{email}}} and {{{title}}}. It must - ;; be done once regular macros have been expanded, since - ;; parsed keywords may contain one of them. - (org-macro-replace-all - (list - (cons "author" (org-element-interpret-data (plist-get info :author))) - (cons "date" - (let* ((date (plist-get info :date)) - (value (or (org-element-interpret-data date) ""))) - (if (and (consp date) - (not (cdr date)) - (eq (org-element-type (car date)) 'timestamp)) - (format "(eval (if (org-string-nw-p \"$1\") %s %S))" - (format "(org-timestamp-format '%S \"$1\")" - (org-element-copy (car date))) - value) - value))) - (cons "email" (org-element-interpret-data (plist-get info :email))) - (cons "title" (org-element-interpret-data (plist-get info :title))) - (cons "results" "$1")) - 'finalize - parsed-keywords) ;; Parse buffer. (setq tree (org-element-parse-buffer nil visible-only)) ;; Prune tree from non-exported elements and transform @@ -3238,7 +3208,7 @@ locally for the subtree through node properties." (org-entry-put node "EXPORT_OPTIONS" (mapconcat 'identity items " ")) (while items - (insert "#+OPTIONS:") + (insert "#+options:") (let ((width 10)) (while (and items (< (+ width (length (car items)) 1) fill-column)) @@ -3264,7 +3234,7 @@ locally for the subtree through node properties." (if subtreep (org-entry-put node (concat "EXPORT_" (car key)) val) (insert (format "#+%s:%s\n" - (car key) + (downcase (car key)) (if (org-string-nw-p val) (format " %s" val) "")))))))) (defun org-export-expand-include-keyword (&optional included dir footnotes) @@ -3275,7 +3245,8 @@ avoid infinite recursion. Optional argument DIR is the current working directory. It is used to properly resolve relative paths. Optional argument FOOTNOTES is a hash-table used for storing and resolving footnotes. It is created automatically." - (let ((case-fold-search t) + (let ((includer-file (buffer-file-name (buffer-base-buffer))) + (case-fold-search t) (file-prefix (make-hash-table :test #'equal)) (current-prefix 0) (footnotes (or footnotes (make-hash-table :test #'equal))) @@ -3298,11 +3269,16 @@ storing and resolving footnotes. It is created automatically." (beginning-of-line) ;; Extract arguments from keyword's value. (let* ((value (org-element-property :value element)) - (ind (org-get-indentation)) + (ind (current-indentation)) location + (coding-system-for-read + (or (and (string-match ":coding +\\(\\S-+\\)>" value) + (prog1 (intern (match-string 1 value)) + (setq value (replace-match "" nil nil value)))) + coding-system-for-read)) (file - (and (string-match - "^\\(\".+?\"\\|\\S-+\\)\\(?:\\s-+\\|$\\)" value) + (and (string-match "^\\(\".+?\"\\|\\S-+\\)\\(?:\\s-+\\|$\\)" + value) (prog1 (save-match-data (let ((matched (match-string 1 value))) @@ -3311,9 +3287,8 @@ storing and resolving footnotes. It is created automatically." (setq location (match-string 2 matched)) (setq matched (replace-match "" nil nil matched 1))) - (expand-file-name - (org-unbracket-string "\"" "\"" matched) - dir))) + (expand-file-name (org-strip-quotes matched) + dir))) (setq value (replace-match "" nil nil value))))) (only-contents (and (string-match ":only-contents *\\([^: \r\t\n]\\S-*\\)?" @@ -3388,10 +3363,12 @@ storing and resolving footnotes. It is created automatically." (insert (org-export--prepare-file-contents file lines ind minlevel - (or - (gethash file file-prefix) - (puthash file (cl-incf current-prefix) file-prefix)) - footnotes))) + (or (gethash file file-prefix) + (puthash file + (cl-incf current-prefix) + file-prefix)) + footnotes + includer-file))) (org-export-expand-include-keyword (cons (list file lines) included) (file-name-directory file) @@ -3468,8 +3445,34 @@ Return a string of lines to be included in the format expected by (while (< (point) end) (cl-incf counter) (forward-line)) counter)))))))) +(defun org-export--update-included-link (file-dir includer-dir) + "Update relative file name of link at point, if possible. + +FILE-DIR is the directory of the file being included. +INCLUDER-DIR is the directory of the file where the inclusion is +going to happen. + +Move point after the link." + (let* ((link (org-element-link-parser)) + (path (org-element-property :path link))) + (if (or (not (string= "file" (org-element-property :type link))) + (file-remote-p path) + (file-name-absolute-p path)) + (goto-char (org-element-property :end link)) + (let ((new-path (file-relative-name (expand-file-name path file-dir) + includer-dir)) + (new-link (org-element-copy link)) + (contents (and (org-element-property :contents-begin link) + (buffer-substring + (org-element-property :contents-begin link) + (org-element-property :contents-end link))))) + (org-element-put-property new-link :path new-path) + (delete-region (org-element-property :begin link) + (org-element-property :end link)) + (insert (org-element-link-interpreter new-link contents)))))) + (defun org-export--prepare-file-contents - (file &optional lines ind minlevel id footnotes) + (file &optional lines ind minlevel id footnotes includer) "Prepare contents of FILE for inclusion and return it as a string. When optional argument LINES is a string specifying a range of @@ -3491,7 +3494,10 @@ This is useful to avoid conflicts when more than one Org file with footnotes is included in a document. Optional argument FOOTNOTES is a hash-table to store footnotes in -the included document." +the included document. + +Optional argument INCLUDER is the file name where the inclusion +is to happen." (with-temp-buffer (insert-file-contents file) (when lines @@ -3507,6 +3513,42 @@ the included document." (forward-line (1- lend)) (point)))) (narrow-to-region beg end))) + ;; Adapt all file links within the included document that contain + ;; relative paths in order to make these paths relative to the + ;; base document, or absolute. + (when includer + (let ((file-dir (file-name-directory file)) + (includer-dir (file-name-directory includer))) + (unless (file-equal-p file-dir includer-dir) + (goto-char (point-min)) + (unless (eq major-mode 'org-mode) + (let ((org-inhibit-startup t)) (org-mode))) ;set regexps + (let ((regexp (concat org-link-plain-re "\\|" org-link-angle-re))) + (while (re-search-forward org-link-any-re nil t) + (let ((link (save-excursion + (forward-char -1) + (save-match-data (org-element-context))))) + (when (eq 'link (org-element-type link)) + ;; Look for file links within link's description. + ;; Org doesn't support such construct, but + ;; `org-export-insert-image-links' may activate + ;; them. + (let ((contents-begin + (org-element-property :contents-begin link)) + (begin (org-element-property :begin link))) + (when contents-begin + (save-excursion + (goto-char (org-element-property :contents-end link)) + (while (re-search-backward regexp contents-begin t) + (save-match-data + (org-export--update-included-link + file-dir includer-dir)) + (goto-char (match-beginning 0))))) + ;; Update current link, if necessary. + (when (string= "file" (org-element-property :type link)) + (goto-char begin) + (org-export--update-included-link + file-dir includer-dir)))))))))) ;; Remove blank lines at beginning and end of contents. The logic ;; behind that removal is that blank lines around include keyword ;; override blank lines in included file. @@ -3665,18 +3707,24 @@ will become the empty string." (cdr (nreverse (cons (funcall prepare-value s) result)))))))) (if property (plist-get attributes property) attributes))) -(defun org-export-get-caption (element &optional shortp) +(defun org-export-get-caption (element &optional short) "Return caption from ELEMENT as a secondary string. -When optional argument SHORTP is non-nil, return short caption, -as a secondary string, instead. +When optional argument SHORT is non-nil, return short caption, as +a secondary string, instead. Caption lines are separated by a white space." - (let ((full-caption (org-element-property :caption element)) caption) - (dolist (line full-caption (cdr caption)) - (let ((cap (funcall (if shortp 'cdr 'car) line))) - (when cap - (setq caption (nconc (list " ") (copy-sequence cap) caption))))))) + (let ((full-caption (org-element-property :caption element)) + (get (if short #'cdr #'car)) + caption) + (dolist (line full-caption) + (pcase (funcall get line) + (`nil nil) + (c + (setq caption + (nconc (list " ") + (copy-sequence c) caption))))) + (cdr caption))) ;;;; For Derived Back-ends @@ -4010,19 +4058,19 @@ inherited from parent headlines and FILETAGS keywords." ;; Add FILETAGS keywords and return results. (org-uniquify (append (plist-get info :filetags) current-tag-list)))))) -(defun org-export-get-node-property (property blob &optional inherited) - "Return node PROPERTY value for BLOB. +(defun org-export-get-node-property (property datum &optional inherited) + "Return node PROPERTY value for DATUM. -PROPERTY is an upcase symbol (i.e. `:COOKIE_DATA'). BLOB is an +PROPERTY is an upcase symbol (e.g., `:COOKIE_DATA'). DATUM is an element or object. If optional argument INHERITED is non-nil, the value can be inherited from a parent headline. Return value is a string or nil." - (let ((headline (if (eq (org-element-type blob) 'headline) blob - (org-export-get-parent-headline blob)))) - (if (not inherited) (org-element-property property blob) + (let ((headline (if (eq (org-element-type datum) 'headline) datum + (org-export-get-parent-headline datum)))) + (if (not inherited) (org-element-property property datum) (let ((parent headline)) (catch 'found (while parent @@ -4120,6 +4168,9 @@ meant to be translated with `org-export-data' or alike." ;; specified id or custom-id in parse tree, the path to the external ;; file with the id. ;; +;; `org-export-resolve-link' searches for the destination of a link +;; within the parsed tree and returns the element. +;; ;; `org-export-resolve-coderef' associates a reference to a line ;; number in the element it belongs, or returns the reference itself ;; when the element isn't numbered. @@ -4150,7 +4201,7 @@ The function ignores links with an implicit type (e.g., (let ((protocol (org-link-get-parameter type :export))) (and (functionp protocol) (funcall protocol - (org-link-unescape (org-element-property :path link)) + (org-element-property :path link) desc backend)))))) @@ -4207,8 +4258,8 @@ structure of RULES. Return modified DATA." (let ((link-re (format "\\`\\(?:%s\\|%s\\)\\'" - org-plain-link-re - org-angle-link-re)) + org-link-plain-re + org-link-angle-re)) (case-fold-search t)) (org-element-map data 'link (lambda (l) @@ -4314,7 +4365,7 @@ as returned by `org-export-search-cells'." (let ((targets (org-export-search-cells datum))) (and targets (cl-some (lambda (cell) (member cell targets)) cells)))) -(defun org-export-resolve-fuzzy-link (link info) +(defun org-export-resolve-fuzzy-link (link info &rest pseudo-types) "Return LINK destination. INFO is a plist holding contextual information. @@ -4331,10 +4382,14 @@ Return value can be an object or an element: - Otherwise, throw an error. +PSEUDO-TYPES are pseudo-elements types, i.e., elements defined +specifically in an export back-end, that could have a name +affiliated keyword. + Assume LINK type is \"fuzzy\". White spaces are not significant." (let* ((search-cells (org-export-string-to-search-cell - (org-link-unescape (org-element-property :path link)))) + (org-element-property :path link))) (link-cache (or (plist-get info :resolve-fuzzy-link-cache) (let ((table (make-hash-table :test #'eq))) (plist-put info :resolve-fuzzy-link-cache table) @@ -4343,7 +4398,7 @@ significant." (if (not (eq cached 'not-found)) cached (let ((matches (org-element-map (plist-get info :parse-tree) - (cons 'target org-element-all-elements) + (append pseudo-types '(target) org-element-all-elements) (lambda (datum) (and (org-export-match-search-cell-p datum search-cells) datum))))) @@ -4402,11 +4457,36 @@ has type \"radio\"." radio)) info 'first-match))) +(defun org-export-resolve-link (link info) + "Return LINK destination. + +LINK is a string or a link object. + +INFO is a plist holding contextual information. + +Return value can be an object or an element: + +- If LINK path matches an ID or a custom ID, return the headline. + +- If LINK path matches a fuzzy link, return its destination. + +- Otherwise, throw an error." + ;; Convert string links to link objects. + (when (stringp link) + (setq link (with-temp-buffer + (save-excursion + (insert (org-link-make-string link))) + (org-element-link-parser)))) + (pcase (org-element-property :type link) + ((or "custom-id" "id") (org-export-resolve-id-link link info)) + ("fuzzy" (org-export-resolve-fuzzy-link link info)) + (_ (signal 'org-link-broken (list (org-element-property :path link)))))) + (defun org-export-file-uri (filename) "Return file URI associated to FILENAME." (cond ((string-prefix-p "//" filename) (concat "file:" filename)) ((not (file-name-absolute-p filename)) filename) - ((org-file-remote-p filename) (concat "file:/" filename)) + ((file-remote-p filename) (concat "file:/" filename)) (t (let ((fullname (expand-file-name filename))) (concat (if (string-prefix-p "/" fullname) "file://" "file:///") @@ -4449,9 +4529,19 @@ REFERENCE is a number representing a reference, as returned by DATUM is either an element or an object. INFO is the current export state, as a plist. -This function checks `:crossrefs' property in INFO for search -cells matching DATUM before creating a new reference. Returned -reference consists of alphanumeric characters only." +References for the current document are stored in +`:internal-references' property. Its value is an alist with +associations of the following types: + + (REFERENCE . DATUM) and (SEARCH-CELL . ID) + +REFERENCE is the reference string to be used for object or +element DATUM. SEARCH-CELL is a search cell, as returned by +`org-export-search-cells'. ID is a number or a string uniquely +identifying DATUM within the document. + +This function also checks `:crossrefs' property for search cells +matching DATUM before creating a new reference." (let ((cache (plist-get info :internal-references))) (or (car (rassq datum cache)) (let* ((crossrefs (plist-get info :crossrefs)) @@ -4861,26 +4951,32 @@ same column as TABLE-CELL, or nil." (plist-put info :table-cell-width-cache table) table))) (width-vector (or (gethash table cache) - (puthash table (make-vector columns 'empty) cache))) - (value (aref width-vector column))) - (if (not (eq value 'empty)) value - (let (cookie-width) - (dolist (row (org-element-contents table) - (aset width-vector column cookie-width)) - (when (org-export-table-row-is-special-p row info) - ;; In a special row, try to find a width cookie at COLUMN. - (let* ((value (org-element-contents - (elt (org-element-contents row) column))) - (cookie (car value))) - ;; The following checks avoid expanding unnecessarily - ;; the cell with `org-export-data'. - (when (and value - (not (cdr value)) - (stringp cookie) - (string-match "\\`<[lrc]?\\([0-9]+\\)?>\\'" cookie) - (match-string 1 cookie)) - (setq cookie-width - (string-to-number (match-string 1 cookie))))))))))) + (puthash table (make-vector columns 'empty) cache)))) + ;; Table rows may not have the same number of cells. Extend + ;; WIDTH-VECTOR appropriately if we encounter a row larger than + ;; expected. + (when (>= column (length width-vector)) + (setq width-vector + (vconcat width-vector + (make-list (- (1+ column) (length width-vector)) + 'empty))) + (puthash table width-vector cache)) + (pcase (aref width-vector column) + (`empty + (catch 'found + (dolist (row (org-element-contents table)) + (when (org-export-table-row-is-special-p row info) + ;; In a special row, try to find a width cookie at + ;; COLUMN. The following checks avoid expanding + ;; unnecessarily the cell with `org-export-data'. + (pcase (org-element-contents + (elt (org-element-contents row) column)) + (`(,(and (pred stringp) cookie)) + (when (string-match "\\`<[lrc]?\\([0-9]+\\)>\\'" cookie) + (let ((w (string-to-number (match-string 1 cookie)))) + (throw 'found (aset width-vector column w)))))))) + (aset width-vector column nil))) + (value value)))) (defun org-export-table-cell-alignment (table-cell info) "Return TABLE-CELL contents alignment. @@ -4905,6 +5001,15 @@ Possible values are `left', `right' and `center'." table))) (align-vector (or (gethash table cache) (puthash table (make-vector columns nil) cache)))) + ;; Table rows may not have the same number of cells. Extend + ;; ALIGN-VECTOR appropriately if we encounter a row larger than + ;; expected. + (when (>= column (length align-vector)) + (setq align-vector + (vconcat align-vector + (make-list (- (1+ column) (length align-vector)) + nil))) + (puthash table align-vector cache)) (or (aref align-vector column) (let ((number-cells 0) (total-cells 0) @@ -5231,10 +5336,12 @@ Footnote sections are ignored." (+ (org-export-get-relative-level scope info) n)) limit)))) (org-element-map (org-element-contents scope) 'headline - (lambda (headline) - (unless (org-element-property :footnote-section-p headline) - (let ((level (org-export-get-relative-level headline info))) - (and (<= level n) headline)))) + (lambda (h) + (and (not (org-element-property :footnote-section-p h)) + (not (equal "notoc" + (org-export-get-node-property :UNNUMBERED h t))) + (>= n (org-export-get-relative-level h info)) + h)) info))) (defun org-export-collect-elements (type info &optional predicate) @@ -5280,13 +5387,27 @@ Return a list of elements recognized as figures." (org-export-collect-elements 'paragraph info predicate)) (defun org-export-collect-listings (info) - "Build a list of src blocks. + "Build a list of source blocks. INFO is a plist used as a communication channel. -Return a list of src-block elements with a caption." +Return a list of `src-block' elements with a caption." (org-export-collect-elements 'src-block info)) +(defun org-export-excluded-from-toc-p (headline info) + "Non-nil if HEADLINE should be excluded from tables of contents. + +INFO is a plist used as a communication channel. + +Note that such headlines are already excluded from +`org-export-collect-headlines'. Therefore, this function is not +necessary if you only need to list headlines in the table of +contents. However, it is useful if some additional processing is +required on headlines excluded from table of contents." + (or (org-element-property :footnote-section-p headline) + (org-export-low-level-p headline info) + (equal "notoc" (org-export-get-node-property :UNNUMBERED headline t)))) + (defun org-export-toc-entry-backend (parent &rest transcoders) "Return an export back-end appropriate for table of contents entries. @@ -5707,6 +5828,7 @@ them." ("ja" :default "前ページからの続き") ("nl" :default "Vervolg van vorige pagina") ("pt" :default "Continuação da página anterior") + ("pt_BR" :html "Continuação da página anterior" :ascii "Continuacao da pagina anterior" :default "Continuação da página anterior") ("ru" :html "(Продолжение)" :utf-8 "(Продолжение)") ("sl" :default "Nadaljevanje s prejšnje strani")) @@ -5720,11 +5842,13 @@ them." ("ja" :default "次ページに続く") ("nl" :default "Vervolg op volgende pagina") ("pt" :default "Continua na página seguinte") + ("pt_BR" :html "Continua na próxima página" :ascii "Continua na proxima pagina" :default "Continua na próxima página") ("ru" :html "(Продолжение следует)" :utf-8 "(Продолжение следует)") ("sl" :default "Nadaljevanje na naslednji strani")) ("Created" ("cs" :default "Vytvořeno") + ("pt_BR" :default "Criado em") ("sl" :default "Ustvarjeno")) ("Date" ("ar" :default "بتاريخ") @@ -5779,6 +5903,7 @@ them." ("es" :default "Figura") ("et" :default "Joonis") ("is" :default "Mynd") + ("it" :default "Figura") ("ja" :default "図" :html "図") ("no" :default "Illustrasjon") ("nb" :default "Illustrasjon") @@ -5796,6 +5921,7 @@ them." ("et" :default "Joonis %d:") ("fr" :default "Figure %d :" :html "Figure %d :") ("is" :default "Mynd %d") + ("it" :default "Figura %d:") ("ja" :default "図%d: " :html "図%d: ") ("no" :default "Illustrasjon %d") ("nb" :default "Illustrasjon %d") @@ -5844,6 +5970,7 @@ them." ("ja" :default "ソースコード目次") ("no" :default "Dataprogrammer") ("nb" :default "Dataprogrammer") + ("pt_BR" :html "Índice de Listagens" :default "Índice de Listagens" :ascii "Indice de Listagens") ("ru" :html "Список распечаток" :utf-8 "Список распечаток") ("sl" :default "Seznam programskih izpisov") @@ -5857,11 +5984,12 @@ them." ("et" :default "Tabelite nimekiri") ("fr" :default "Liste des tableaux") ("is" :default "Töfluskrá" :html "Töfluskrá") + ("it" :default "Indice delle tabelle") ("ja" :default "表目次") ("no" :default "Tabeller") ("nb" :default "Tabeller") ("nn" :default "Tabeller") - ("pt_BR" :default "Índice de Tabelas" :ascii "Indice de Tabelas") + ("pt_BR" :html "Índice de Tabelas" :default "Índice de Tabelas" :ascii "Indice de Tabelas") ("ru" :html "Список таблиц" :utf-8 "Список таблиц") ("sl" :default "Seznam tabel") @@ -5875,6 +6003,7 @@ them." ("es" :default "Listado de programa") ("et" :default "Loend") ("fr" :default "Programme" :html "Programme") + ("it" :default "Listato") ("ja" :default "ソースコード") ("no" :default "Dataprogram") ("nb" :default "Dataprogram") @@ -5891,10 +6020,11 @@ them." ("es" :default "Listado de programa %d") ("et" :default "Loend %d") ("fr" :default "Programme %d :" :html "Programme %d :") + ("it" :default "Listato %d :") ("ja" :default "ソースコード%d:") ("no" :default "Dataprogram %d") ("nb" :default "Dataprogram %d") - ("pt_BR" :default "Listagem %d") + ("pt_BR" :default "Listagem %d:") ("ru" :html "Распечатка %d.:" :utf-8 "Распечатка %d.:") ("sl" :default "Izpis programa %d") @@ -5902,19 +6032,24 @@ them." ("References" ("ar" :default "المراجع") ("cs" :default "Reference") - ("fr" :ascii "References" :default "Références") ("de" :default "Quellen") ("es" :default "Referencias") + ("fr" :ascii "References" :default "Références") + ("it" :default "Riferimenti") + ("pt_BR" :html "Referências" :default "Referências" :ascii "Referencias") ("sl" :default "Reference")) ("See figure %s" ("cs" :default "Viz obrázek %s") ("fr" :default "cf. figure %s" :html "cf. figure %s" :latex "cf.~figure~%s") + ("it" :default "Vedi figura %s") + ("pt_BR" :default "Veja a figura %s") ("sl" :default "Glej sliko %s")) ("See listing %s" ("cs" :default "Viz program %s") ("fr" :default "cf. programme %s" :html "cf. programme %s" :latex "cf.~programme~%s") + ("pt_BR" :default "Veja a listagem %s") ("sl" :default "Glej izpis programa %s")) ("See section %s" ("ar" :default "انظر قسم %s") @@ -5924,6 +6059,7 @@ them." ("es" :ascii "Vea seccion %s" :html "Vea sección %s" :default "Vea sección %s") ("et" :html "Vaata peatükki %s" :utf-8 "Vaata peatükki %s") ("fr" :default "cf. section %s") + ("it" :default "Vedi sezione %s") ("ja" :default "セクション %s を参照") ("pt_BR" :html "Veja a seção %s" :default "Veja a seção %s" :ascii "Veja a secao %s") @@ -5935,6 +6071,8 @@ them." ("cs" :default "Viz tabulka %s") ("fr" :default "cf. tableau %s" :html "cf. tableau %s" :latex "cf.~tableau~%s") + ("it" :default "Vedi tabella %s") + ("pt_BR" :default "Veja a tabela %s") ("sl" :default "Glej tabelo %s")) ("Table" ("ar" :default "جدول") @@ -5944,6 +6082,7 @@ them." ("et" :default "Tabel") ("fr" :default "Tableau") ("is" :default "Tafla") + ("it" :default "Tabella") ("ja" :default "表" :html "表") ("pt_BR" :default "Tabela") ("ru" :html "Таблица" @@ -5958,11 +6097,12 @@ them." ("et" :default "Tabel %d") ("fr" :default "Tableau %d :") ("is" :default "Tafla %d") + ("it" :default "Tabella %d:") ("ja" :default "表%d:" :html "表%d:") ("no" :default "Tabell %d") ("nb" :default "Tabell %d") ("nn" :default "Tabell %d") - ("pt_BR" :default "Tabela %d") + ("pt_BR" :default "Tabela %d:") ("ru" :html "Таблица %d.:" :utf-8 "Таблица %d.:") ("sl" :default "Tabela %d") @@ -6003,9 +6143,9 @@ them." ("es" :default "Referencia desconocida") ("et" :default "Tundmatu viide") ("fr" :ascii "Destination inconnue" :default "Référence inconnue") + ("it" :default "Riferimento sconosciuto") ("ja" :default "不明な参照先") - ("pt_BR" :default "Referência desconhecida" - :ascii "Referencia desconhecida") + ("pt_BR" :html "Referência desconhecida" :default "Referência desconhecida" :ascii "Referencia desconhecida") ("ru" :html "Неизвестная ссылка" :utf-8 "Неизвестная ссылка") ("sl" :default "Neznana referenca") |