diff options
Diffstat (limited to 'lisp/org/org.el')
| -rw-r--r-- | lisp/org/org.el | 18407 |
1 files changed, 9759 insertions, 8648 deletions
diff --git a/lisp/org/org.el b/lisp/org/org.el index 02a7a0c09af..22b7dbfdaf4 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -1,4 +1,4 @@ -;;; org.el --- Outline-based notes management and organizer +;;; org.el --- Outline-based notes management and organizer -*- lexical-binding: t; -*- ;; Carstens outline-mode for keeping track of everything. ;; Copyright (C) 2004-2017 Free Software Foundation, Inc. @@ -25,23 +25,24 @@ ;; ;;; Commentary: ;; -;; Org-mode is a mode for keeping notes, maintaining ToDo lists, and doing +;; Org is a mode for keeping notes, maintaining ToDo lists, and doing ;; project planning with a fast and effective plain-text system. ;; -;; Org-mode develops organizational tasks around NOTES files that contain -;; information about projects as plain text. Org-mode is implemented on -;; top of outline-mode, which makes it possible to keep the content of -;; large files well structured. Visibility cycling and structure editing -;; help to work with the tree. Tables are easily created with a built-in -;; table editor. Org-mode supports ToDo items, deadlines, time stamps, -;; and scheduling. It dynamically compiles entries into an agenda that -;; utilizes and smoothly integrates much of the Emacs calendar and diary. -;; Plain text URL-like links connect to websites, emails, Usenet -;; messages, BBDB entries, and any files related to the projects. For -;; printing and sharing of notes, an Org-mode file can be exported as a -;; structured ASCII file, as HTML, or (todo and agenda items only) as an -;; iCalendar file. It can also serve as a publishing tool for a set of -;; linked webpages. +;; Org mode develops organizational tasks around NOTES files that +;; contain information about projects as plain text. Org mode is +;; implemented on top of outline-mode, which makes it possible to keep +;; the content of large files well structured. Visibility cycling and +;; structure editing help to work with the tree. Tables are easily +;; created with a built-in table editor. Org mode supports ToDo +;; items, deadlines, time stamps, and scheduling. It dynamically +;; compiles entries into an agenda that utilizes and smoothly +;; integrates much of the Emacs calendar and diary. Plain text +;; URL-like links connect to websites, emails, Usenet messages, BBDB +;; entries, and any files related to the projects. For printing and +;; sharing of notes, an Org file can be exported as a structured ASCII +;; file, as HTML, or (todo and agenda items only) as an iCalendar +;; file. It can also serve as a publishing tool for a set of linked +;; webpages. ;; ;; Installation and Activation ;; --------------------------- @@ -51,11 +52,11 @@ ;; ;; Documentation ;; ------------- -;; The documentation of Org-mode can be found in the TeXInfo file. The +;; The documentation of Org mode can be found in the TeXInfo file. The ;; distribution also contains a PDF version of it. At the homepage of -;; Org-mode, you can read the same text online as HTML. There is also an +;; Org mode, you can read the same text online as HTML. There is also an ;; excellent reference card made by Philip Rooke. This card can be found -;; in the etc/ directory of Emacs 22. +;; in the doc/ directory. ;; ;; A list of recent changes can be found at ;; http://orgmode.org/Changes.html @@ -63,21 +64,29 @@ ;;; Code: (defvar org-inhibit-highlight-removal nil) ; dynamically scoped param -(defvar org-table-formula-constants-local nil +(defvar-local org-table-formula-constants-local nil "Local version of `org-table-formula-constants'.") -(make-variable-buffer-local 'org-table-formula-constants-local) ;;;; Require other packages -(eval-when-compile - (require 'cl) - (require 'gnus-sum)) +(require 'cl-lib) + +(eval-when-compile (require 'gnus-sum)) (require 'calendar) (require 'find-func) (require 'format-spec) -(load "org-loaddefs.el" t t t) +(or (eq this-command 'eval-buffer) + (condition-case nil + (load (concat (file-name-directory load-file-name) + "org-loaddefs.el") + nil t t t) + (error + (message "WARNING: No org-loaddefs.el file could be found from where org.el is loaded.") + (sit-for 3) + (message "You need to run \"make\" or \"make autoloads\" from Org lisp directory") + (sit-for 3)))) (require 'org-macs) (require 'org-compat) @@ -101,75 +110,87 @@ sure that we are at the beginning of the line.") "Matches a headline, putting stars and text into groups. Stars are put in group 1 and the trimmed body in group 2.") -;; Emacs 22 calendar compatibility: Make sure the new variables are available -(unless (boundp 'calendar-view-holidays-initially-flag) - (org-defvaralias 'calendar-view-holidays-initially-flag - 'view-calendar-holidays-initially)) -(unless (boundp 'calendar-view-diary-initially-flag) - (org-defvaralias 'calendar-view-diary-initially-flag - 'view-diary-entries-initially)) -(unless (boundp 'diary-fancy-buffer) - (org-defvaralias 'diary-fancy-buffer 'fancy-diary-buffer)) - +(declare-function calendar-check-holidays "holidays" (date)) +(declare-function cdlatex-environment "ext:cdlatex" (environment item)) +(declare-function isearch-no-upper-case-p "isearch" (string regexp-flag)) (declare-function org-add-archive-files "org-archive" (files)) - -(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-pop-to-buffer-same-window "org-compat" (&optional buffer-or-name norecord label)) +(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-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-get-last-clock-out-time "org-clock" ()) -(declare-function org-clock-timestamps-up "org-clock" (&optional n)) -(declare-function org-clock-timestamps-down "org-clock" (&optional n)) +(declare-function org-clock-out "org-clock" (&optional switch-to-state fail-quietly at-time)) (declare-function org-clock-remove-overlays "org-clock" (&optional beg end noremove)) +(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)) +(declare-function org-clock-timestamps-up "org-clock" (&optional n)) (declare-function org-clock-update-time-maybe "org-clock" ()) (declare-function org-clocktable-shift "org-clock" (dir n)) - -(declare-function orgtbl-mode "org-table" (&optional arg)) -(declare-function org-clock-out "org-clock" (&optional switch-to-state fail-quietly at-time)) -(declare-function org-beamer-mode "ox-beamer" (&optional prefix) t) -(declare-function org-table-edit-field "org-table" (arg)) -(declare-function org-table-justify-field-maybe "org-table" (&optional new)) -(declare-function org-table-set-constants "org-table" ()) -(declare-function org-table-calc-current-TBLFM "org-table" (&optional arg)) -(declare-function org-id-get-create "org-id" (&optional force)) +(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-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" ()) +(declare-function org-element-nested-p "org-element" (elem-a elem-b)) +(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-swap-A-B "org-element" (elem-a elem-b)) +(declare-function org-element-type "org-element" (element)) +(declare-function org-element-update-syntax "org-element" ()) (declare-function org-id-find-id-file "org-id" (id)) -(declare-function org-tags-view "org-agenda" (&optional todo-only match)) -(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-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-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-paste-rectangle "org-table" ()) +(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-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-element--parse-objects "org-element" - (beg end acc restriction)) -(declare-function org-element-at-point "org-element" (&optional keep-trail)) -(declare-function org-element-contents "org-element" (element)) -(declare-function org-element-context "org-element" (&optional element)) -(declare-function org-element-interpret-data "org-element" - (data &optional parent)) -(declare-function org-element-map "org-element" - (data types fun &optional - info first-match no-recursion with-affiliated)) -(declare-function org-element-nested-p "org-element" (elem-a elem-b)) -(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-swap-A-B "org-element" (elem-a elem-b)) -(declare-function org-element--parse-objects "org-element" - (beg end acc restriction)) -(declare-function org-element-parse-buffer "org-element" - (&optional granularity visible-only)) -(declare-function org-element-restriction "org-element" (element)) -(declare-function org-element-type "org-element" (element)) +(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))) ;; load languages based on value of `org-babel-load-languages' (defvar org-babel-load-languages) @@ -178,28 +199,24 @@ Stars are put in group 1 and the trimmed body in group 2.") (defun org-babel-do-load-languages (sym value) "Load the languages defined in `org-babel-load-languages'." (set-default sym value) - (mapc (lambda (pair) - (let ((active (cdr pair)) (lang (symbol-name (car pair)))) - (if active - (progn - (require (intern (concat "ob-" lang)))) - (progn - (funcall 'fmakunbound - (intern (concat "org-babel-execute:" lang))) - (funcall 'fmakunbound - (intern (concat "org-babel-expand-body:" lang))))))) - org-babel-load-languages)) + (dolist (pair org-babel-load-languages) + (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))))))) (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-mode FILE. + "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." (interactive "fFile to load: \nP") - (require 'ob-core) (let* ((age (lambda (file) (float-time (time-subtract (current-time) @@ -207,11 +224,13 @@ file to byte-code before it is loaded." (file-attributes file))))))) (base-name (file-name-sans-extension file)) (exported-file (concat base-name ".el"))) - ;; tangle if the org-mode file is newer than the elisp file + ;; 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 (org-babel-tangle-file file exported-file "emacs-lisp")))) + (car (last (org-babel-tangle-file file exported-file "emacs-lisp"))))) (message "%s %s" (if compile (progn (byte-compile-file exported-file 'load) @@ -220,7 +239,7 @@ file to byte-code before it is loaded." exported-file))) (defcustom org-babel-load-languages '((emacs-lisp . t)) - "Languages which can be evaluated in Org-mode buffers. + "Languages which can be evaluated in Org buffers. 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 @@ -246,10 +265,12 @@ requirements) is loaded." (const :tag "Ditaa" ditaa) (const :tag "Dot" dot) (const :tag "Emacs Lisp" emacs-lisp) + (const :tag "Forth" forth) (const :tag "Fortran" fortran) (const :tag "Gnuplot" gnuplot) (const :tag "Haskell" haskell) (const :tag "IO" io) + (const :tag "J" J) (const :tag "Java" java) (const :tag "Javascript" js) (const :tag "LaTeX" latex) @@ -272,10 +293,12 @@ requirements) is loaded." (const :tag "Scala" scala) (const :tag "Scheme" scheme) (const :tag "Screen" screen) - (const :tag "Shell Script" sh) + (const :tag "Shell Script" shell) (const :tag "Shen" shen) (const :tag "Sql" sql) - (const :tag "Sqlite" sqlite)) + (const :tag "Sqlite" sqlite) + (const :tag "Stan" stan) + (const :tag "ebnf2ps" ebnf2ps)) :value-type (boolean :tag "Activate" :value t))) ;;;; Customization variables @@ -293,41 +316,318 @@ identifier." ;;;###autoload (defun org-version (&optional here full message) - "Show the org-mode version in the echo area. -With prefix argument HERE, insert it at point. -When FULL is non-nil, use a verbose version string. -When MESSAGE is non-nil, display a message with the version." - (interactive "P") - (let* ((org-dir (ignore-errors (org-find-library-dir "org"))) - (save-load-suffixes (when (boundp 'load-suffixes) load-suffixes)) - (load-suffixes (list ".el")) - (org-install-dir (ignore-errors (org-find-library-dir "org-loaddefs"))) - (org-trash (or - (and (fboundp 'org-release) (fboundp 'org-git-version)) - (org-load-noerror-mustsuffix (concat org-dir "org-version")))) - (load-suffixes save-load-suffixes) - (org-version (org-release)) - (git-version (org-git-version)) - (version (format "Org-mode version %s (%s @ %s)" - org-version - git-version - (if org-install-dir - (if (string= org-dir org-install-dir) - org-install-dir - (concat "mixed installation! " org-install-dir " and " org-dir)) - "org-loaddefs.el can not be found!"))) - (version1 (if full version org-version))) - (if (org-called-interactively-p 'interactive) - (if here - (insert version) - (message version)) - (if message (message version1)) + "Show the Org version. +Interactively, or when MESSAGE is non-nil, show it in echo area. +With prefix argument, or when HERE is non-nil, insert it at point. +In non-interactive uses, a reduced version string is output unless +FULL is given." + (interactive (list current-prefix-arg t (not current-prefix-arg))) + (let ((org-dir (ignore-errors (org-find-library-dir "org"))) + (save-load-suffixes (when (boundp 'load-suffixes) load-suffixes)) + (load-suffixes (list ".el")) + (org-install-dir + (ignore-errors (org-find-library-dir "org-loaddefs")))) + (unless (and (fboundp 'org-release) (fboundp 'org-git-version)) + (org-load-noerror-mustsuffix (concat org-dir "org-version"))) + (let* ((load-suffixes save-load-suffixes) + (release (org-release)) + (git-version (org-git-version)) + (version (format "Org mode version %s (%s @ %s)" + release + git-version + (if org-install-dir + (if (string= org-dir org-install-dir) + org-install-dir + (concat "mixed installation! " + org-install-dir + " and " + org-dir)) + "org-loaddefs.el can not be found!"))) + (version1 (if full version release))) + (when here (insert version1)) + (when message (message "%s" version1)) version1))) (defconst org-version (org-version)) -;;; Compatibility constants + +;;; Syntax Constants + +;;;; Block + +(defconst org-block-regexp + "^[ \t]*#\\+begin_?\\([^ \n]+\\)\\(\\([^\n]+\\)\\)?\n\\([^\000]+?\\)#\\+end_?\\1[ \t]*$" + "Regular expression for hiding blocks.") + +(defconst org-dblock-start-re + "^[ \t]*#\\+\\(?:BEGIN\\|begin\\):[ \t]+\\(\\S-+\\)\\([ \t]+\\(.*\\)\\)?" + "Matches the start line of a dynamic block, with parameters.") + +(defconst org-dblock-end-re "^[ \t]*#\\+\\(?:END\\|end\\)\\([: \t\r\n]\\|$\\)" + "Matches the end of a dynamic block.") + +;;;; Clock and Planning + +(defconst org-clock-string "CLOCK:" + "String used as prefix for timestamps clocking work hours on an item.") + +(defvar org-closed-string "CLOSED:" + "String used as the prefix for timestamps logging closing a TODO entry.") + +(defvar org-deadline-string "DEADLINE:" + "String to mark deadline entries. +\\<org-mode-map> +A deadline is this string, followed by a time stamp. It must be +a word, terminated by a colon. You can insert a schedule keyword +and a timestamp with `\\[org-deadline]'.") + +(defvar org-scheduled-string "SCHEDULED:" + "String to mark scheduled TODO entries. +\\<org-mode-map> +A schedule is this string, followed by a time stamp. It must be +a word, terminated by a colon. You can insert a schedule keyword +and a timestamp with `\\[org-schedule]'.") + +(defconst org-ds-keyword-length + (+ 2 + (apply #'max + (mapcar #'length + (list org-deadline-string org-scheduled-string + org-clock-string org-closed-string)))) + "Maximum length of the DEADLINE and SCHEDULED keywords.") + +(defconst org-planning-line-re + (concat "^[ \t]*" + (regexp-opt + (list org-closed-string org-deadline-string org-scheduled-string) + t)) + "Matches a line with planning info. +Matched keyword is in group 1.") + +(defconst org-clock-line-re + (concat "^[ \t]*" org-clock-string) + "Matches a line with clock info.") + +(defconst org-deadline-regexp (concat "\\<" org-deadline-string) + "Matches the DEADLINE keyword.") + +(defconst org-deadline-time-regexp + (concat "\\<" org-deadline-string " *<\\([^>]+\\)>") + "Matches the DEADLINE keyword together with a time stamp.") + +(defconst org-deadline-time-hour-regexp + (concat "\\<" org-deadline-string + " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9-+:hdwmy \t.]*\\)>") + "Matches the DEADLINE keyword together with a time-and-hour stamp.") + +(defconst org-deadline-line-regexp + (concat "\\<\\(" org-deadline-string "\\).*") + "Matches the DEADLINE keyword and the rest of the line.") + +(defconst org-scheduled-regexp (concat "\\<" org-scheduled-string) + "Matches the SCHEDULED keyword.") + +(defconst org-scheduled-time-regexp + (concat "\\<" org-scheduled-string " *<\\([^>]+\\)>") + "Matches the SCHEDULED keyword together with a time stamp.") + +(defconst org-scheduled-time-hour-regexp + (concat "\\<" org-scheduled-string + " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9-+:hdwmy \t.]*\\)>") + "Matches the SCHEDULED keyword together with a time-and-hour stamp.") + +(defconst org-closed-time-regexp + (concat "\\<" org-closed-string " *\\[\\([^]]+\\)\\]") + "Matches the CLOSED keyword together with a time stamp.") + +(defconst org-keyword-time-regexp + (concat "\\<" + (regexp-opt + (list org-scheduled-string org-deadline-string org-closed-string + org-clock-string) + t) + " *[[<]\\([^]>]+\\)[]>]") + "Matches any of the 4 keywords, together with the time stamp.") + +(defconst org-keyword-time-not-clock-regexp + (concat + "\\<" + (regexp-opt + (list org-scheduled-string org-deadline-string org-closed-string) t) + " *[[<]\\([^]>]+\\)[]>]") + "Matches any of the 3 keywords, together with the time stamp.") + +(defconst org-maybe-keyword-time-regexp + (concat "\\(\\<" + (regexp-opt + (list org-scheduled-string org-deadline-string org-closed-string + org-clock-string) + t) + "\\)?" + " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?[]>]" + "\\|" + "<%%([^\r\n>]*>\\)") + "Matches a timestamp, possibly preceded by a keyword.") + +(defconst org-all-time-keywords + (mapcar (lambda (w) (substring w 0 -1)) + (list org-scheduled-string org-deadline-string + org-clock-string org-closed-string)) + "List of time keywords.") + +;;;; Drawer + +(defconst org-drawer-regexp "^[ \t]*:\\(\\(?:\\w\\|[-_]\\)+\\):[ \t]*$" + "Matches first or last line of a hidden block. +Group 1 contains drawer's name or \"END\".") + +(defconst org-property-start-re "^[ \t]*:PROPERTIES:[ \t]*$" + "Regular expression matching the first line of a property drawer.") + +(defconst org-property-end-re "^[ \t]*:END:[ \t]*$" + "Regular expression matching the last line of a property drawer.") + +(defconst org-clock-drawer-start-re "^[ \t]*:CLOCK:[ \t]*$" + "Regular expression matching the first line of a clock drawer.") + +(defconst org-clock-drawer-end-re "^[ \t]*:END:[ \t]*$" + "Regular expression matching the last line of a clock drawer.") + +(defconst org-property-drawer-re + (concat "^[ \t]*:PROPERTIES:[ \t]*\n" + "\\(?:[ \t]*:\\S-+:\\(?: .*\\)?[ \t]*\n\\)*?" + "[ \t]*:END:[ \t]*$") + "Matches an entire property drawer.") + +(defconst org-clock-drawer-re + (concat "\\(" org-clock-drawer-start-re "\\)[^\000]*?\\(" + org-clock-drawer-end-re "\\)\n?") + "Matches an entire clock drawer.") + +;;;; Headline + +(defconst org-heading-keyword-regexp-format + "^\\(\\*+\\)\\(?: +%s\\)\\(?: +\\(.*?\\)\\)?[ \t]*$" + "Printf format for a regexp matching a headline with some keyword. +This regexp will match the headline of any node which has the +exact keyword that is put into the format. The keyword isn't in +any group by default, but the stars and the body are.") + +(defconst org-heading-keyword-maybe-regexp-format + "^\\(\\*+\\)\\(?: +%s\\)?\\(?: +\\(.*?\\)\\)?[ \t]*$" + "Printf format for a regexp matching a headline, possibly with some keyword. +This regexp can match any headline with the specified keyword, or +without a keyword. The keyword isn't in any group by default, +but the stars and the body are.") + +(defconst org-archive-tag "ARCHIVE" + "The tag that marks a subtree as archived. +An archived subtree does not open during visibility cycling, and does +not contribute to the agenda listings.") + +(defconst org-comment-string "COMMENT" + "Entries starting with this keyword will never be exported. +\\<org-mode-map> +An entry can be toggled between COMMENT and normal with +`\\[org-toggle-comment]'.") + + +;;;; LaTeX Environments and Fragments + +(defconst org-latex-regexps + '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) + ;; ("$" "\\([ \t(]\\|^\\)\\(\\(\\([$]\\)\\([^ \t\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \t\n,.$]\\)\\4\\)\\)\\([ \t.,?;:'\")]\\|$\\)" 2 nil) + ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p + ("$1" "\\([^$]\\|^\\)\\(\\$[^ \t\r\n,;.$]\\$\\)\\(\\s.\\|\\s-\\|\\s(\\|\\s)\\|\\s\"\\|\000\\|'\\|$\\)" 2 nil) + ("$" "\\([^$]\\|^\\)\\(\\(\\$\\([^ \t\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \t\n,.$]\\)\\$\\)\\)\\(\\s.\\|\\s-\\|\\s(\\|\\s)\\|\\s\"\\|\000\\|'\\|$\\)" 2 nil) + ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) + ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 nil) + ("$$" "\\$\\$[^\000]*?\\$\\$" 0 nil)) + "Regular expressions for matching embedded LaTeX.") + +;;;; Node Property + +(defconst org-effort-property "Effort" + "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>]*?\\)>" + "Regular expression for fast time stamp matching.") + +(defconst org-ts-regexp-inactive + "\\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)\\]" + "Regular expression for fast inactive time stamp matching.") + +(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?\\)[]>]" + "Regular expression for fast time stamp matching.") + +(defconst org-ts-regexp0 + "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\)\\( +[^]+0-9>\r\n -]+\\)?\\( +\\([0-9]\\{1,2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)" + "Regular expression matching time strings for analysis. +This one does not require the space after the date, so it can be used +on a string that terminates immediately after the date.") + +(defconst org-ts-regexp1 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\) *\\([^]+0-9>\r\n -]*\\)\\( \\([0-9]\\{1,2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)" + "Regular expression matching time strings for analysis.") + +(defconst org-ts-regexp2 (concat "<" org-ts-regexp1 "[^>\n]\\{0,16\\}>") + "Regular expression matching time stamps, with groups.") + +(defconst org-ts-regexp3 (concat "[[<]" org-ts-regexp1 "[^]>\n]\\{0,16\\}[]>]") + "Regular expression matching time stamps (also [..]), with groups.") + +(defconst org-tr-regexp (concat org-ts-regexp "--?-?" org-ts-regexp) + "Regular expression matching a time stamp range.") +(defconst org-tr-regexp-both + (concat org-ts-regexp-both "--?-?" org-ts-regexp-both) + "Regular expression matching a time stamp range.") + +(defconst org-tsr-regexp (concat org-ts-regexp "\\(--?-?" + org-ts-regexp "\\)?") + "Regular expression matching a time stamp or time stamp range.") + +(defconst org-tsr-regexp-both + (concat org-ts-regexp-both "\\(--?-?" + org-ts-regexp-both "\\)?") + "Regular expression matching a time stamp or time stamp range. +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]\\)?\\)" + "Regular expression for specifying repeated events. +After a match, group 1 contains the repeat expression.") + +(defconst org-time-stamp-formats '("<%Y-%m-%d %a>" . "<%Y-%m-%d %a %H:%M>") + "Formats for `format-time-string' which are used for time stamps.") + + ;;; The custom variables (defgroup org nil @@ -337,7 +637,7 @@ When MESSAGE is non-nil, display a message with the version." :group 'calendar) (defcustom org-mode-hook nil - "Mode hook for Org-mode, run after the mode was turned on." + "Mode hook for Org mode, run after the mode was turned on." :group 'org :type 'hook) @@ -359,17 +659,17 @@ When MESSAGE is non-nil, display a message with the version." (defun org-load-modules-maybe (&optional force) "Load all extensions listed in `org-modules'." (when (or force (not org-modules-loaded)) - (mapc (lambda (ext) - (condition-case nil (require ext) - (error (message "Problems while trying to load feature `%s'" ext)))) - org-modules) + (dolist (ext org-modules) + (condition-case nil (require ext) + (error (message "Problems while trying to load feature `%s'" ext)))) (setq org-modules-loaded t))) (defun org-set-modules (var value) "Set VAR to VALUE and call `org-load-modules-maybe' with the force flag." (set var value) (when (featurep 'org) - (org-load-modules-maybe 'force))) + (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) "Modules that should always be loaded together with org.el. @@ -397,6 +697,7 @@ For export specific modules, see also `org-export-backends'." (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 " habit: Track your consistency with habits" org-habit) (const :tag " id: Global IDs for identifying entries" org-id) @@ -407,52 +708,50 @@ For export specific modules, see also `org-export-backends'." (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 " w3m: Special cut/paste from w3m to Org mode." org-w3m) (const :tag "C annotate-file: Annotate a file with org syntax" org-annotate-file) - (const :tag "C bookmark: Org-mode links to bookmarks" org-bookmark) + (const :tag "C bookmark: Org links to bookmarks" org-bookmark) (const :tag "C bullets: Add overlays to headlines stars" org-bullets) (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-mode links to emacs-lisp symbols" org-elisp-symbol) + (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 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-mode entries" org-expiry) + (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 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 jira: Add a jira:ticket protocol to Org-mode" org-jira) + (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-link: Grab links and url from various mac Applications" org-mac-link) - (const :tag "C mairix: Hook mairix search into Org-mode for different MUAs" org-mairix) - (const :tag "C man: Support for links to manpages in Org-mode" org-man) + (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 panel: Simple routines for us with bad memory" org-panel) - (const :tag "C registry: A registry for Org-mode links" org-registry) - (const :tag "C screen: Visit screen sessions through Org-mode links" org-screen) + (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 secretary: Team management with org-mode" org-secretary) - (const :tag "C sqlinsert: Convert Org-mode tables to SQL insertions" orgtbl-sqlinsert) - (const :tag "C toc: Table of contents for Org-mode buffer" org-toc) - (const :tag "C track: Keep up with Org-mode development" org-track) + (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 wikinodes: CamelCase wiki-like links" org-wikinodes) (const :tag "C wl: Links to Wanderlust folders/messages" org-wl) (repeat :tag "External packages" :inline t (symbol :tag "Package")))) -(defvar org-export--registered-backends) ; From ox.el. +(defvar org-export-registered-backends) ; From ox.el. (declare-function org-export-derived-backend-p "ox" (backend &rest backends)) (declare-function org-export-backend-name "ox" (backend) t) -(declare-function org-export-backend-options "ox" (cl-x) t) -(defcustom org-export-backends '(ascii html icalendar latex) +(defcustom org-export-backends '(ascii html icalendar latex odt) "List of export back-ends that should be always available. If a description starts with <C>, the file is not part of Emacs @@ -469,8 +768,8 @@ interface or run the following code, where VAL stands for the new value of the variable, after updating it: (progn - (setq org-export--registered-backends - (org-remove-if-not + (setq org-export-registered-backends + (cl-remove-if-not (lambda (backend) (let ((name (org-export-backend-name backend))) (or (memq name val) @@ -478,9 +777,9 @@ value of the variable, after updating it: (dolist (b val) (and (org-export-derived-backend-p b name) (throw \\='parentp t))))))) - org-export--registered-backends)) - (let ((new-list (mapcar \\='org-export-backend-name - org-export--registered-backends))) + org-export-registered-backends)) + (let ((new-list (mapcar #\\='org-export-backend-name + org-export-registered-backends))) (dolist (backend val) (cond ((not (load (format \"ox-%s\" backend) t t)) @@ -493,16 +792,16 @@ Adding a back-end to this list will also pull the back-end it depends on, if any." :group 'org :group 'org-export - :version "24.4" - :package-version '(Org . "8.0") + :version "26.1" + :package-version '(Org . "9.0") :initialize 'custom-initialize-set :set (lambda (var val) (if (not (featurep 'ox)) (set-default var val) ;; Any back-end not required anymore (not present in VAL and not ;; a parent of any back-end in the new value) is removed from the ;; list of registered back-ends. - (setq org-export--registered-backends - (org-remove-if-not + (setq org-export-registered-backends + (cl-remove-if-not (lambda (backend) (let ((name (org-export-backend-name backend))) (or (memq name val) @@ -510,11 +809,11 @@ depends on, if any." (dolist (b val) (and (org-export-derived-backend-p b name) (throw 'parentp t))))))) - org-export--registered-backends)) + org-export-registered-backends)) ;; Now build NEW-LIST of both new back-ends and required ;; parents. - (let ((new-list (mapcar 'org-export-backend-name - org-export--registered-backends))) + (let ((new-list (mapcar #'org-export-backend-name + org-export-registered-backends))) (dolist (backend val) (cond ((not (load (format "ox-%s" backend) t t)) @@ -544,19 +843,18 @@ depends on, if any." (const :tag "C taskjuggler Export buffer to TaskJuggler format" taskjuggler))) (eval-after-load 'ox - '(mapc - (lambda (backend) - (condition-case nil (require (intern (format "ox-%s" backend))) - (error (message "Problems while trying to load export back-end `%s'" - backend)))) - org-export-backends)) + '(dolist (backend org-export-backends) + (condition-case nil (require (intern (format "ox-%s" backend))) + (error (message "Problems while trying to load export back-end `%s'" + backend))))) (defcustom org-support-shift-select nil "Non-nil means make shift-cursor commands select text when possible. +\\<org-mode-map>\ In Emacs 23, when `shift-select-mode' is on, shifted cursor keys start selecting a region, or enlarge regions started in this way. -In Org-mode, in special contexts, these same keys are used for +In Org mode, in special contexts, these same keys are used for other purposes, important enough to compete with shift selection. Org tries to balance these needs by supporting `shift-select-mode' outside these special contexts, under control of this variable. @@ -571,7 +869,7 @@ cursor keys will then execute Org commands in the following contexts: Outside these contexts, the commands will throw an error. When this variable is t and the cursor is not in a special -context, Org-mode will support shift-selection for making and +context, Org mode will support shift-selection for making and enlarging regions. To make this more effective, the bullet cycling will no longer happen anywhere in an item line, but only if the cursor is exactly on the bullet. @@ -579,16 +877,16 @@ if the cursor is exactly on the bullet. If you set this variable to the symbol `always', then the keys will not be special in headlines, property lines, and item lines, to make shift selection work there as well. If this is what you -want, you can use the following alternative commands: `C-c C-t' -and `C-c ,' to change TODO state and priority, `C-u C-u C-c C-t' -can be used to switch TODO sets, `C-c -' to cycle item bullet -types, and properties can be edited by hand or in column view. +want, you can use the following alternative commands: +`\\[org-todo]' and `\\[org-priority]' \ +to change TODO state and priority, +`\\[universal-argument] \\[universal-argument] \\[org-todo]' \ +can be used to switch TODO sets, +`\\[org-ctrl-c-minus]' to cycle item bullet types, +and properties can be edited by hand or in column view. However, when the cursor is on a timestamp, shift-cursor commands -will still edit the time stamp - this is just too good to give up. - -XEmacs user should have this variable set to nil, because -`shift-select-mode' is in Emacs 23 or later only." +will still edit the time stamp - this is just too good to give up." :group 'org :type '(choice (const :tag "Never" nil) @@ -622,12 +920,13 @@ already archived entries." :group 'org-archive) (defgroup org-startup nil - "Options concerning startup of Org-mode." + "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. + "Non-nil means entering Org mode will switch to OVERVIEW. + This can also be configured on a per-file basis by adding one of the following lines anywhere in the buffer: @@ -636,9 +935,9 @@ the following lines anywhere in the buffer: #+STARTUP: content #+STARTUP: showeverything -By default, this option is ignored when Org opens agenda files -for the first time. If you want the agenda to honor the startup -option, set `org-agenda-inhibit-startup' to nil." +Set `org-agenda-inhibit-startup' to a non-nil value if you want +to ignore this option when Org opens agenda files for the first +time." :group 'org-startup :type '(choice (const :tag "nofold: show all" nil) @@ -647,9 +946,18 @@ option, set `org-agenda-inhibit-startup' to nil." (const :tag "show everything, even drawers" showeverything))) (defcustom org-startup-truncated t - "Non-nil means entering Org-mode will set `truncate-lines'. + "Non-nil means entering Org mode will set `truncate-lines'. This is useful since some lines containing links can be very long and -uninteresting. Also tables look terrible when wrapped." +uninteresting. Also tables look terrible when wrapped. + +The variable `org-startup-truncated' allows to configure +truncation for Org mode different to the other modes that use the +variable `truncate-lines' and as a shortcut instead of putting +the variable `truncate-lines' into the `org-mode-hook'. If one +wants to configure truncation for Org mode not statically but +dynamically e. g. in a hook like `ediff-prepare-buffer-hook' then +the variable `truncate-lines' has to be used because in such a +case it is too late to set the variable `org-startup-truncated'." :group 'org-startup :type 'boolean) @@ -742,26 +1050,26 @@ the following lines anywhere in the buffer: :type 'boolean) (defcustom org-insert-mode-line-in-empty-file nil - "Non-nil means insert the first line setting Org-mode in empty files. + "Non-nil means insert the first line setting Org mode in empty files. When the function `org-mode' is called interactively in an empty file, this -normally means that the file name does not automatically trigger Org-mode. -To ensure that the file will always be in Org-mode in the future, a -line enforcing Org-mode will be inserted into the buffer, if this option +normally means that the file name does not automatically trigger Org mode. +To ensure that the file will always be in Org mode in the future, a +line enforcing Org mode will be inserted into the buffer, if this option has been set." :group 'org-startup :type 'boolean) (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. +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 +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 +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 @@ -769,18 +1077,13 @@ become effective." (defcustom org-use-extra-keys nil "Non-nil means use extra key sequence definitions for certain commands. -This happens automatically if you run XEmacs or if `window-system' -is nil. This variable lets you do the same manually. You must -set it before loading org. - -Example: on Carbon Emacs 22 running graphically, with an external -keyboard on a Powerbook, the default way of setting M-left might -not work for either Alt or ESC. Setting this variable will make -it work for ESC." +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) -(org-defvaralias 'org-CUA-compatible 'org-replace-disputed-keys) +(defvaralias 'org-CUA-compatible 'org-replace-disputed-keys) (defcustom org-disputed-keys '(([(shift up)] . [(meta p)]) @@ -789,90 +1092,52 @@ it work for ESC." ([(shift right)] . [(meta +)]) ([(control shift right)] . [(meta shift +)]) ([(control shift left)] . [(meta shift -)])) - "Keys for which Org-mode and other modes compete. + "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's startup, +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. -Also apply the translations defined in `org-xemacs-key-equivalents'." +Or return the original if not disputed." (when org-replace-disputed-keys (let* ((nkey (key-description key)) - (x (org-find-if (lambda (x) - (equal (key-description (car x)) nkey)) - org-disputed-keys))) + (x (cl-find-if (lambda (x) (equal (key-description (car x)) nkey)) + org-disputed-keys))) (setq key (if x (cdr x) key)))) - (when (featurep 'xemacs) - (setq key (or (cdr (assoc key org-xemacs-key-equivalents)) key))) key) -(defun org-find-if (predicate seq) - (catch 'exit - (while seq - (if (funcall predicate (car seq)) - (throw 'exit (car seq)) - (pop seq))))) - (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. + "The ellipsis to use in the Org mode outline. + When nil, just use the standard three dots. When a string, use that string instead. -When a face, use the standard 3 dots, but with the specified face. -The change affects only Org-mode (which will then use its own display table). + +The change affects only Org mode (which will then use its own display table). Changing this requires executing `\\[org-mode]' in a buffer to become effective." :group 'org-startup :type '(choice (const :tag "Default" nil) - (face :tag "Face" :value org-warning) - (string :tag "String" :value "...#"))) + (string :tag "String" :value "...#")) + :safe #'string-or-null-p) (defvar org-display-table nil "The display table for org-mode, in case `org-ellipsis' is non-nil.") (defgroup org-keywords nil - "Keywords in Org-mode." + "Keywords in Org mode." :tag "Org Keywords" :group 'org) -(defcustom org-deadline-string "DEADLINE:" - "String to mark deadline entries. -A deadline is this string, followed by a time stamp. Should be a word, -terminated by a colon. You can insert a schedule keyword and -a timestamp with \\[org-deadline]. -Changes become only effective after restarting Emacs." - :group 'org-keywords - :type 'string) - -(defcustom org-scheduled-string "SCHEDULED:" - "String to mark scheduled TODO entries. -A schedule is this string, followed by a time stamp. Should be a word, -terminated by a colon. You can insert a schedule keyword and -a timestamp with \\[org-schedule]. -Changes become only effective after restarting Emacs." - :group 'org-keywords - :type 'string) - -(defcustom org-closed-string "CLOSED:" - "String used as the prefix for timestamps logging closing a TODO entry." - :group 'org-keywords - :type 'string) - -(defcustom org-clock-string "CLOCK:" - "String used as prefix for timestamps clocking work hours on an item." - :group 'org-keywords - :type 'string) - (defcustom org-closed-keep-when-no-todo nil "Remove CLOSED: time-stamp when switching back to a non-todo state?" :group 'org-todo @@ -881,37 +1146,8 @@ Changes become only effective after restarting Emacs." :package-version '(Org . "8.0") :type 'boolean) -(defconst org-planning-or-clock-line-re (concat "^[ \t]*\\(" - org-scheduled-string "\\|" - org-deadline-string "\\|" - org-closed-string "\\|" - org-clock-string "\\)") - "Matches a line with planning or clock info.") - -(defcustom org-comment-string "COMMENT" - "Entries starting with this keyword will never be exported. -An entry can be toggled between COMMENT and normal with -\\[org-toggle-comment]. -Changes become only effective after restarting Emacs." - :group 'org-keywords - :type 'string) - -(defcustom org-quote-string "QUOTE" - "Entries starting with this keyword will be exported in fixed-width font. -Quoting applies only to the text in the entry following the headline, and does -not extend beyond the next headline, even if that is lower level. -An entry can be toggled between QUOTE and normal with -\\[org-toggle-fixed-width-section]." - :group 'org-keywords - :type 'string) - -(defconst org-repeat-re - "<[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.") - (defgroup org-structure nil - "Options concerning the general structure of Org-mode files." + "Options concerning the general structure of Org files." :tag "Org Structure" :group 'org) @@ -920,92 +1156,88 @@ After a match, group 1 contains the repeat expression.") :tag "Org Reveal Location" :group 'org-structure) -(defconst org-context-choice - '(choice - (const :tag "Always" t) - (const :tag "Never" nil) - (repeat :greedy t :tag "Individual contexts" - (cons - (choice :tag "Context" - (const agenda) - (const org-goto) - (const occur-tree) - (const tags-tree) - (const link-search) - (const mark-goto) - (const bookmark-jump) - (const isearch) - (const default)) - (boolean)))) - "Contexts for the reveal options.") - -(defcustom org-show-hierarchy-above '((default . t)) - "Non-nil means show full hierarchy when revealing a location. -Org-mode often shows locations in an org-mode file which might have -been invisible before. When this is set, the hierarchy of headings -above the exposed location is shown. -Turning this off for example for sparse trees makes them very compact. -Instead of t, this can also be an alist specifying this option for different -contexts. Valid contexts are +(defcustom org-show-context-detail '((agenda . local) + (bookmark-jump . lineage) + (isearch . lineage) + (default . ancestors)) + "Alist between context and visibility span when revealing a location. + +\\<org-mode-map>Some actions may move point into invisible +locations. As a consequence, Org always expose a neighborhood +around point. How much is shown depends on the initial action, +or context. Valid contexts are + agenda when exposing an entry from the agenda - org-goto when using the command `org-goto' on key C-c C-j - occur-tree when using the command `org-occur' on key C-c / + org-goto when using the command `org-goto' (`\\[org-goto]') + occur-tree when using the command `org-occur' (`\\[org-sparse-tree] /') tags-tree when constructing a sparse tree based on tags matches link-search when exposing search matches associated with a link mark-goto when exposing the jump goal of a mark bookmark-jump when exposing a bookmark location isearch when exiting from an incremental search - default default for all contexts not set explicitly" - :group 'org-reveal-location - :type org-context-choice) - -(defcustom org-show-following-heading '((default . nil)) - "Non-nil means show following heading when revealing a location. -Org-mode often shows locations in an org-mode file which might have -been invisible before. When this is set, the heading following the -match is shown. -Turning this off for example for sparse trees makes them very compact, -but makes it harder to edit the location of the match. In such a case, -use the command \\[org-reveal] to show more context. -Instead of t, this can also be an alist specifying this option for different -contexts. See `org-show-hierarchy-above' for valid contexts." - :group 'org-reveal-location - :type org-context-choice) - -(defcustom org-show-siblings '((default . nil) (isearch t) (bookmark-jump t)) - "Non-nil means show all sibling heading when revealing a location. -Org-mode often shows locations in an org-mode file which might have -been invisible before. When this is set, the sibling of the current entry -heading are all made visible. If `org-show-hierarchy-above' is t, -the same happens on each level of the hierarchy above the current entry. - -By default this is on for the isearch context, off for all other contexts. -Turning this off for example for sparse trees makes them very compact, -but makes it harder to edit the location of the match. In such a case, -use the command \\[org-reveal] to show more context. -Instead of t, this can also be an alist specifying this option for different -contexts. See `org-show-hierarchy-above' for valid contexts." - :group 'org-reveal-location - :type org-context-choice - :version "24.4" - :package-version '(Org . "8.0")) + default default for all contexts not set explicitly + +Allowed visibility spans are + + minimal show current headline; if point is not on headline, + also show entry + + local show current headline, entry and next headline -(defcustom org-show-entry-below '((default . nil)) - "Non-nil means show the entry below a headline when revealing a location. -Org-mode often shows locations in an org-mode file which might have -been invisible before. When this is set, the text below the headline that is -exposed is also shown. + ancestors show current headline and its direct ancestors; if + point is not on headline, also show entry -By default this is off for all contexts. -Instead of t, this can also be an alist specifying this option for different -contexts. See `org-show-hierarchy-above' for valid contexts." + lineage show current headline, its direct ancestors and all + their children; if point is not on headline, also show + entry and first child + + tree show current headline, its direct ancestors and all + their children; if point is not on headline, also show + entry and all children + + canonical show current headline, its direct ancestors along with + their entries and children; if point is not located on + the headline, also show current entry and all children + +As special cases, a nil or t value means show all contexts in +`minimal' or `canonical' view, respectively. + +Some views can make displayed information very compact, but also +make it harder to edit the location of the match. In such +a case, use the command `org-reveal' (`\\[org-reveal]') to show +more context." :group 'org-reveal-location - :type org-context-choice) + :version "26.1" + :package-version '(Org . "9.0") + :type '(choice + (const :tag "Canonical" t) + (const :tag "Minimal" nil) + (repeat :greedy t :tag "Individual contexts" + (cons + (choice :tag "Context" + (const agenda) + (const org-goto) + (const occur-tree) + (const tags-tree) + (const link-search) + (const mark-goto) + (const bookmark-jump) + (const isearch) + (const default)) + (choice :tag "Detail level" + (const minimal) + (const local) + (const ancestors) + (const lineage) + (const tree) + (const canonical)))))) (defcustom org-indirect-buffer-display 'other-window "How should indirect tree buffers be displayed? + This applies to indirect buffers created with the commands -\\[org-tree-to-indirect-buffer] and \\[org-agenda-tree-to-indirect-buffer]. +`org-tree-to-indirect-buffer' and `org-agenda-tree-to-indirect-buffer'. + Valid values are: current-window Display in the current window other-window Just display in another window. @@ -1024,7 +1256,13 @@ new-frame Make a new frame each time. Note that in this case (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." +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) @@ -1054,10 +1292,10 @@ commands in the Help buffer using the `?' speed command." (sexp)))))) (defcustom org-bookmark-names-plist - '(:last-capture "org-capture-last-stored" - :last-refile "org-refile-last-stored" - :last-capture-marker "org-capture-last-stored-marker") - "Names for bookmarks automatically set by some Org commands. + '(:last-capture "org-capture-last-stored" + :last-refile "org-refile-last-stored" + :last-capture-marker "org-capture-last-stored-marker") + "Names for bookmarks automatically set by some Org commands. This can provide strings as names for a number of bookmarks Org sets automatically. The following keys are currently implemented: :last-capture @@ -1065,11 +1303,11 @@ automatically. The following keys are currently implemented: :last-refile When a key does not show up in the property list, the corresponding bookmark is not set." - :group 'org-structure - :type 'plist) + :group 'org-structure + :type 'plist) (defgroup org-cycle nil - "Options concerning visibility cycling in Org-mode." + "Options concerning visibility cycling in Org mode." :tag "Org Cycle" :group 'org-structure) @@ -1093,25 +1331,8 @@ than its value." (const :tag "No limit" nil) (integer :tag "Maximum level"))) -(defcustom org-drawers '("PROPERTIES" "CLOCK" "LOGBOOK" "RESULTS") - "Names of drawers. Drawers are not opened by cycling on the headline above. -Drawers only open with a TAB on the drawer line itself. A drawer looks like -this: - :DRAWERNAME: - ..... - :END: -The drawer \"PROPERTIES\" is special for capturing properties through -the property API. - -Drawers can be defined on the per-file basis with a line like: - -#+DRAWERS: HIDDEN STATE PROPERTIES" - :group 'org-structure - :group 'org-cycle - :type '(repeat (string :tag "Drawer Name"))) - (defcustom org-hide-block-startup nil - "Non-nil means entering Org-mode will fold all blocks. + "Non-nil means entering Org mode will fold all blocks. This can also be set in on a per-file basis with #+STARTUP: hideblocks @@ -1122,12 +1343,17 @@ This can also be set in on a per-file basis with (defcustom org-cycle-global-at-bob nil "Cycle globally if cursor is at beginning of buffer and not at a headline. -This makes it possible to do global cycling without having to use S-TAB or -\\[universal-argument] TAB. For this special case to work, the first line -of the buffer must not be a headline -- it may be empty or some other text. + +This makes it possible to do global cycling without having to use `S-TAB' +or `\\[universal-argument] TAB'. For this special case to work, the first \ +line of the buffer +must not be a headline -- it may be empty or some other text. + When used in this way, `org-cycle-hook' is disabled temporarily to make -sure the cursor stays at the beginning of the buffer. When this option is -nil, don't do anything special at the beginning of the buffer." +sure the cursor stays at the beginning of the buffer. + +When this option is nil, don't do anything special at the beginning of +the buffer." :group 'org-cycle :type 'boolean) @@ -1166,7 +1392,7 @@ visibility is cycled." "Number of empty lines needed to keep an empty line between collapsed trees. If you leave an empty line between the end of a subtree and the following headline, this empty line is hidden when the subtree is folded. -Org-mode will leave (exactly) one empty line visible if the number of +Org mode will leave (exactly) one empty line visible if the number of empty lines is equal or larger to the number given in this variable. So the default 2 means at least 2 empty lines after the end of a subtree are needed to produce free space between a collapsed subtree and the @@ -1192,7 +1418,6 @@ the values `folded', `children', or `subtree'." (defcustom org-cycle-hook '(org-cycle-hide-archived-subtrees org-cycle-hide-drawers - org-cycle-hide-inline-tasks org-cycle-show-empty-lines org-optimize-window-after-visibility-change) "Hook that is run after `org-cycle' has changed the buffer visibility. @@ -1202,10 +1427,12 @@ argument is a symbol. After a global state change, it can have the values `overview', `contents', or `all'. After a local state change, it can have the values `folded', `children', or `subtree'." :group 'org-cycle - :type 'hook) + :type 'hook + :version "26.1" + :package-version '(Org . "8.3")) (defgroup org-edit-structure nil - "Options concerning structure editing in Org-mode." + "Options concerning structure editing in Org mode." :tag "Org Edit Structure" :group 'org-structure) @@ -1229,23 +1456,25 @@ lines to the buffer: "Non-nil means adapt indentation to outline node level. When this variable is set, Org assumes that you write outlines by -indenting text in each node to align with the headline (after the stars). -The following issues are influenced by this variable: +indenting text in each node to align with the headline (after the +stars). The following issues are influenced by this variable: -- When this is set and the *entire* text in an entry is indented, the - indentation is increased by one space in a demotion command, and - decreased by one in a promotion command. If any line in the entry - body starts with text at column 0, indentation is not changed at all. +- The indentation is increased by one space in a demotion + command, and decreased by one in a promotion command. However, + in the latter case, if shifting some line in the entry body + would alter document structure (e.g., insert a new headline), + indentation is not changed at all. -- Property drawers and planning information is inserted indented when - this variable s set. When nil, they will not be indented. +- Property drawers and planning information is inserted indented + when this variable is set. When nil, they will not be indented. -- TAB indents a line relative to context. The lines below a headline - will be indented when this variable is set. +- TAB indents a line relative to current level. The lines below + 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 level-dependent -indentation in a virtual way, i.e. at display time in Emacs." +Note that this is all about true indentation, by adding and +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) @@ -1286,7 +1515,7 @@ This may also be a cons cell where the behavior for `C-a' and (const :tag "off" nil) (const :tag "on: before tags first" t) (const :tag "reversed: after tags first" reversed))))) -(org-defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e) +(defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e) (defcustom org-special-ctrl-k nil "Non-nil means `C-k' will behave specially in headlines. @@ -1386,9 +1615,11 @@ default the value to be used for all contexts not explicitly (defcustom org-insert-heading-respect-content nil "Non-nil means insert new headings after the current subtree. +\\<org-mode-map> When nil, the new heading is created directly after the current line. -The commands \\[org-insert-heading-respect-content] and \\[org-insert-todo-heading-respect-content] turn -this variable on for the duration of the command." +The commands `\\[org-insert-heading-respect-content]' and \ +`\\[org-insert-todo-heading-respect-content]' turn this variable on +for the duration of the command." :group 'org-structure :type 'boolean) @@ -1398,11 +1629,7 @@ this variable on for the duration of the command." The value is an alist, with `heading' and `plain-list-item' as CAR, and a boolean flag as CDR. The cdr may also be the symbol `auto', in which case Org will look at the surrounding headings/items and try to -make an intelligent decision whether to insert a blank line or not. - -For plain lists, if `org-list-empty-line-terminates-plain-lists' is set, -the setting here is ignored and no empty line is inserted to avoid breaking -the list structure." +make an intelligent decision whether to insert a blank line or not." :group 'org-edit-structure :type '(list (cons (const heading) @@ -1422,8 +1649,7 @@ the list structure." (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. -See also the QUOTE keyword." +When nil, such lines will be treated like ordinary lines." :group 'org-edit-structure :type 'boolean) @@ -1441,7 +1667,7 @@ When nil, you can use these keybindings to navigate the buffer: :type 'boolean) (defgroup org-sparse-trees nil - "Options concerning sparse trees in Org-mode." + "Options concerning sparse trees in Org mode." :tag "Org Sparse Trees" :group 'org-structure) @@ -1454,14 +1680,26 @@ changed by an edit command." (defcustom org-remove-highlights-with-change t "Non-nil means any change to the buffer will remove temporary highlights. +\\<org-mode-map>\ Such highlights are created by `org-occur' and `org-clock-display'. -When nil, `C-c C-c' needs to be used to get rid of the highlights. -The highlights created by `org-preview-latex-fragment' always need -`C-c C-c' to be removed." +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." :group 'org-sparse-trees :group 'org-time :type 'boolean) +(defcustom org-occur-case-fold-search t + "Non-nil means `org-occur' should be case-insensitive. +If set to `smart' the search will be case-insensitive only if it +doesn't specify any upper case character." + :group 'org-sparse-trees + :version "26.1" + :type '(choice + (const :tag "Case-sensitive" nil) + (const :tag "Case-insensitive" t) + (const :tag "Case-insensitive for lower case searches only" 'smart))) (defcustom org-occur-hook '(org-first-headline-recenter) "Hook that is run after `org-occur' has constructed a sparse tree. @@ -1471,18 +1709,18 @@ as possible." :type 'hook) (defgroup org-imenu-and-speedbar nil - "Options concerning imenu and speedbar in Org-mode." + "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-mode headlines. + "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." + "Options concerning tables in Org mode." :tag "Org Table" :group 'org) @@ -1499,12 +1737,12 @@ do the following: TAB or RET are pressed to move to another field. With optimization this happens only if changes to a field might have changed the column width. Optimization requires replacing the functions `self-insert-command', -`delete-char', and `backward-delete-char' in Org-mode buffers, with a -slight (in fact: unnoticeable) speed impact for normal typing. Org-mode is -very good at guessing when a re-align will be necessary, but you can always -force one with \\[org-ctrl-c-ctrl-c]. +`delete-char', and `backward-delete-char' in Org buffers, with a +slight (in fact: unnoticeable) speed impact for normal typing. Org is very +good at guessing when a re-align will be necessary, but you can always +force one with `\\[org-ctrl-c-ctrl-c]'. -If you would like to use the optimized version in Org-mode, but the +If you would like to use the optimized version in Org mode, but the un-optimized version in OrgTbl-mode, see the variable `orgtbl-optimized'. This variable can be used to turn on and off the table editor during a session, @@ -1517,8 +1755,7 @@ See also the variable `org-table-auto-blank-field'." (const :tag "on" t) (const :tag "on, optimized" optimized))) -(defcustom org-self-insert-cluster-for-undo (or (featurep 'xemacs) - (version<= emacs-version "24.1")) +(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 characters will be undone together. @@ -1534,24 +1771,95 @@ calls `table-recognize-table'." :type 'boolean) (defgroup org-link nil - "Options concerning links in Org-mode." + "Options concerning links in Org mode." :tag "Org Link" :group 'org) -(defvar org-link-abbrev-alist-local nil +(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.") -(make-variable-buffer-local 'org-link-abbrev-alist-local) + +(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)))) + ("message" :follow (lambda (path) (browse-url (concat "message:" 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)) + +(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-mode buffers can have an optional tag after a double colon, e.g. +links in Org buffers can have an optional tag after a double colon, e.g., [[linkkey:tag][description]] -The `linkkey' must be a word word, starting with a letter, followed +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. @@ -1603,11 +1911,18 @@ adaptive Use relative path for files in the current directory and sub- (const noabbrev) (const adaptive))) -(defcustom org-activate-links '(bracket angle plain radio tag date footnote) - "Types of links that should be activated in Org-mode files. -This is a list of symbols, each leading to the activation of a certain link -type. In principle, it does not hurt to turn on most link types - there may -be a small gain when turning off unused link types. The types are: +(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. + +This is a list of symbols, each one of them leading to the +highlighting of a certain link type. + +You can still open links that are not highlighted. + +In principle, it does not hurt to turn on highlighting for all +link types. There may be a small gain when turning off unused +link types. The types are: bracket The recommended [[link][description]] or [[link]] links with hiding. angle Links in angular brackets that may contain whitespace like @@ -1618,8 +1933,10 @@ tag Tag settings in a headline (link to tag search). date Time stamps (link to calendar). footnote Footnote labels. -Changing this variable requires a restart of Emacs to become effective." +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) (const :tag "Angular bracket links" angle) @@ -1639,7 +1956,7 @@ return the description to use." :type '(choice (const nil) (function))) (defgroup org-link-store nil - "Options concerning storing links in Org-mode." + "Options concerning storing links in Org mode." :tag "Org Store Link" :group 'org-link) @@ -1684,32 +2001,36 @@ It should match if the message is from the user him/herself." (defcustom org-context-in-file-links t "Non-nil means file links from `org-store-link' contain context. -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-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] (`org-store-link') +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-mode 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." +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." + "Options concerning following links in Org mode." :tag "Org Follow Link" :group 'org-link) @@ -1749,8 +2070,8 @@ In tables, the special behavior of RET has precedence." (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. Does not work on XEmacs. -Needs to be set before org.el is loaded." +A longer mouse click will still set point. Needs to be set +before org.el is loaded." :group 'org-link-follow :version "24.4" :package-version '(Org . "8.3") @@ -1766,16 +2087,22 @@ Changing this requires a restart of Emacs to work correctly." :type 'integer) (defcustom org-link-search-must-match-exact-headline 'query-to-create - "Non-nil means internal links in Org files must exactly match a headline. -When nil, the link search tries to match a phrase with all words -in the search text." + "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))) + query-to-create)) + :safe #'symbolp) (defcustom org-link-frame-setup '((vm . vm-visit-folder-other-frame) @@ -1836,7 +2163,7 @@ another window." "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 \ +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 @@ -1860,26 +2187,13 @@ window on that directory." :group 'org-link-follow :type 'boolean) -(defcustom org-link-mailto-program '(browse-url "mailto:%a?subject=%s") - "Function and arguments to call for following mailto links. -This is a list with the first element being a Lisp function, and the -remaining elements being arguments to the function. In string arguments, -%a will be replaced by the address, and %s will be replaced by the subject -if one was given like in <mailto:arthur@galaxy.org::this subject>." - :group 'org-link-follow - :type '(choice - (const :tag "browse-url" (browse-url-mail "mailto:%a?subject=%s")) - (const :tag "compose-mail" (compose-mail "%a" "%s")) - (const :tag "message-mail" (message-mail "%a" "%s")) - (cons :tag "other" (function) (repeat :tag "argument" sexp)))) - (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-mode document as \"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 @@ -1891,7 +2205,7 @@ single keystroke rather than having to type \"yes\"." (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)))) + (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." @@ -1905,7 +2219,7 @@ 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-mode document as \"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 @@ -1917,7 +2231,7 @@ single keystroke rather than having to type \"yes\"." (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)))) + (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." @@ -1934,30 +2248,23 @@ See `org-file-apps'.") (defconst org-file-apps-defaults-macosx '((remote . emacs) - (t . "open %s") (system . "open %s") ("ps.gz" . "gv %s") ("eps.gz" . "gv %s") ("dvi" . "xdvi %s") - ("fig" . "xfig %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 t - (list (if (featurep 'xemacs) - 'mswindows-shell-execute - 'w32-shell-execute) - "open" 'file)) - (cons 'system - (list (if (featurep 'xemacs) - 'mswindows-shell-execute - 'w32-shell-execute) - "open" 'file))) + (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'.") @@ -1968,11 +2275,15 @@ See `org-file-apps'.") ("\\.x?html?\\'" . default) ("\\.pdf\\'" . default)) "External applications for opening `file:path' items in a document. -Org-mode uses system defaults for different file types, but +\\<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 +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: @@ -1985,8 +2296,8 @@ file identifier are filename matches the regexp. If you want to use groups here, use shy groups. - Example: (\"\\.x?html\\\\='\" . \"firefox %s\") - (\"\\(?:xhtml\\|html\\)\" . \"firefox %s\") + Example: (\"\\\\.x?html\\\\\\='\" . \"firefox %s\") + (\"\\\\(?:xhtml\\\\|html\\\\)\\\\\\='\" . \"firefox %s\") to open *.html and *.xhtml with firefox. - Regular expression which contains (non-shy) groups: @@ -1998,10 +2309,11 @@ file identifier are 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 lisp form, you can access the group matches with + In a custom function, you can access the group matches with (match-string n link). - Example: (\"\\.pdf::\\(\\d+\\)\\\\='\" . \"evince -p %1 %s\") + Example: (\"\\\\.pdf::\\\\(\\\\d+\\\\)\\\\\\='\" . \ +\"evince -p %1 %s\") to open [[file:document.pdf::5]] with evince at page 5. `directory' Matches a directory @@ -2013,28 +2325,32 @@ file identifier are 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. - t Default for files not matched by any of the other options. `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 `C-c C-o' with a double - \\[universal-argument] \\[universal-argument] prefix. + 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 + 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. - sexp A Lisp form which will be evaluated. The file path will - be available in the Lisp variable `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' @@ -2054,7 +2370,7 @@ For more examples, see the system specific constants (const :tag "Use default" default) (const :tag "Use the system command" system) (string :tag "Command") - (sexp :tag "Lisp form"))))) + (function :tag "Function"))))) (defcustom org-doi-server-url "http://dx.doi.org/" "The URL of the DOI server." @@ -2063,22 +2379,22 @@ For more examples, see the system specific constants :group 'org-link-follow) (defgroup org-refile nil - "Options concerning refiling entries in Org-mode." + "Options concerning refiling entries in Org mode." :tag "Org Refile" :group 'org) (defcustom org-directory "~/org" - "Directory with org files. + "Directory with Org files. This is just a default location to look for Org files. There is no need -at all to put your files into this directory. It is only used in the +at all to put your files into this directory. It is used in the following situations: 1. When a capture template specifies a target file that is not an absolute path. The path will then be interpreted relative to `org-directory' -2. When a capture note is filed away in an interactive way (when exiting the - note buffer with `C-1 C-c C-c'. The user is prompted for an org file, - with `org-directory' as the default path." +2. When the value of variable `org-agenda-files' is a single file, any + relative paths in this file will be taken as relative to + `org-directory'." :group 'org-refile :group 'org-capture :type 'directory) @@ -2089,9 +2405,7 @@ Used as a fall back file for org-capture.el, for templates that do not specify a target file." :group 'org-refile :group 'org-capture - :type '(choice - (const :tag "Default from remember-data-file" nil) - file)) + :type 'file) (defcustom org-goto-interface 'outline "The default interface to be used for `org-goto'. @@ -2154,7 +2468,7 @@ will temporarily be changed to `time'." (const :tag "Record timestamp with note." note))) (defcustom org-refile-targets nil - "Targets for refiling entries with \\[org-refile]. + "Targets for refiling entries with `\\[org-refile]'. This is a list of cons cells. Each cell contains: - a specification of the files to be considered, either a list of files, or a symbol whose function or variable value will be used to retrieve @@ -2218,12 +2532,15 @@ of the subtree." (defcustom org-refile-use-cache nil "Non-nil means cache refile targets to speed up the process. +\\<org-mode-map>\ The cache for a particular file will be updated automatically when the buffer has been killed, or when any of the marker used for flagging refile targets no longer points at a live buffer. If you have added new entries to a buffer that might themselves be targets, -you need to clear the cache manually by pressing `C-0 C-c C-w' or, if you -find that easier, `C-u C-u C-u C-c C-w'." +you need to clear the cache manually by pressing `C-0 \\[org-refile]' or, +if you find that easier, \ +`\\[universal-argument] \\[universal-argument] \\[universal-argument] \ +\\[org-refile]'." :group 'org-refile :version "24.1" :type 'boolean) @@ -2246,13 +2563,13 @@ When `full-file-path', include the full file path." (defcustom org-outline-path-complete-in-steps t "Non-nil means complete the outline path in hierarchical steps. -When Org-mode uses the refile interface to select an outline path -\(see variable `org-refile-use-outline-path'), the completion of -the path can be done is a single go, or if can be done in steps down -the headline hierarchy. Going in steps is probably the best if you -do not use a special completion package like `ido' or `icicles'. -However, when using these packages, going in one step can be very -fast, while still showing the whole path to the entry." +When Org uses the refile interface to select an outline path (see +`org-refile-use-outline-path'), the completion of the path can be +done in a single go, or it can be done in steps down the headline +hierarchy. Going in steps is probably the best if you do not use +a special completion package like `ido' or `icicles'. However, +when using these packages, going in one step can be very fast, +while still showing the whole path to the entry." :group 'org-refile :type 'boolean) @@ -2285,12 +2602,12 @@ converted to a headline before refiling." :type 'boolean) (defgroup org-todo nil - "Options concerning TODO items in Org-mode." + "Options concerning TODO items in Org mode." :tag "Org TODO" :group 'org) (defgroup org-progress nil - "Options concerning Progress logging in Org-mode." + "Options concerning Progress logging in Org mode." :tag "Org Progress" :group 'org-time) @@ -2308,12 +2625,12 @@ Each sequence starts with a symbol, either `sequence' or `type', indicating if the keywords should be interpreted as a sequence of action steps, or as different types of TODO items. The first keywords are states requiring action - these states will select a headline -for inclusion into the global TODO list Org-mode produces. If one of -the \"keywords\" is the vertical bar, \"|\", the remaining keywords +for inclusion into the global TODO list Org produces. If one of the +\"keywords\" is the vertical bar, \"|\", the remaining keywords signify that no further action is necessary. If \"|\" is not found, the last keyword is treated as the only DONE state of the sequence. -The command \\[org-todo] cycles an entry through these states, and one +The command `\\[org-todo]' cycles an entry through these states, and one additional state where no keyword is present. For details about this cycling, see the manual. @@ -2356,44 +2673,37 @@ taken from the (otherwise obsolete) variable `org-todo-interpretation'." (lambda (widget) (widget-put widget :args (mapcar - #'(lambda (x) - (widget-convert - (cons 'const x))) + (lambda (x) + (widget-convert + (cons 'const x))) org-todo-interpretation-widgets)) widget)) (repeat (string :tag "Keyword")))))) -(defvar org-todo-keywords-1 nil +(defvar-local org-todo-keywords-1 nil "All TODO and DONE keywords active in a buffer.") -(make-variable-buffer-local 'org-todo-keywords-1) (defvar org-todo-keywords-for-agenda nil) (defvar org-done-keywords-for-agenda nil) -(defvar org-drawers-for-agenda nil) (defvar org-todo-keyword-alist-for-agenda nil) (defvar org-tag-alist-for-agenda nil "Alist of all tags from all agenda files.") (defvar org-tag-groups-alist-for-agenda nil "Alist of all groups tags from all current agenda files.") -(defvar org-tag-groups-alist nil) -(make-variable-buffer-local 'org-tag-groups-alist) +(defvar-local org-tag-groups-alist nil) (defvar org-agenda-contributing-files nil) -(defvar org-not-done-keywords nil) -(make-variable-buffer-local 'org-not-done-keywords) -(defvar org-done-keywords nil) -(make-variable-buffer-local 'org-done-keywords) -(defvar org-todo-heads nil) -(make-variable-buffer-local 'org-todo-heads) -(defvar org-todo-sets nil) -(make-variable-buffer-local 'org-todo-sets) -(defvar org-todo-log-states nil) -(make-variable-buffer-local 'org-todo-log-states) -(defvar org-todo-kwd-alist nil) -(make-variable-buffer-local 'org-todo-kwd-alist) -(defvar org-todo-key-alist nil) -(make-variable-buffer-local 'org-todo-key-alist) -(defvar org-todo-key-trigger nil) -(make-variable-buffer-local 'org-todo-key-trigger) +(defvar-local org-current-tag-alist nil + "Alist of all tag groups in current buffer. +This variable takes into consideration `org-tag-alist', +`org-tag-persistent-alist' and TAGS keywords in the buffer.") +(defvar-local org-not-done-keywords nil) +(defvar-local org-done-keywords nil) +(defvar-local org-todo-heads nil) +(defvar-local org-todo-sets nil) +(defvar-local org-todo-log-states nil) +(defvar-local org-todo-kwd-alist nil) +(defvar-local org-todo-key-alist nil) +(defvar-local org-todo-key-trigger nil) (defcustom org-todo-interpretation 'sequence "Controls how TODO keywords are interpreted. @@ -2407,7 +2717,8 @@ more information." (const type))) (defcustom org-use-fast-todo-selection t - "Non-nil means use the fast todo selection scheme with C-c C-t. + "\\<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. @@ -2415,8 +2726,9 @@ selection scheme. When nil, fast selection is never used. When the symbol `prefix', it will be used when `org-todo' is called -with a prefix argument, i.e. `C-u C-c C-t' in an Org-mode buffer, and -`C-u t' in an agenda buffer. +with a prefix argument, i.e. `\\[universal-argument] \\[org-todo]' \ +in an Org buffer, and +`\\[universal-argument] t' in an agenda buffer. When t, fast selection is used by default. In this case, the prefix argument forces cycling instead. @@ -2436,6 +2748,9 @@ ALL-HEADLINES means update todo statistics by including headlines with no TODO keyword as well, counting them as not done. A list of TODO keywords means the same, but skip keywords that are not in this list. +When set to a list of two lists, the first list contains keywords +to consider as TODO keywords, the second list contains keywords +to consider as DONE keywords. When this is set, todo statistics is updated in the parent of the current entry each time a todo state is changed." @@ -2445,6 +2760,9 @@ current entry each time a todo state is changed." (const :tag "Yes, including all entries" all-headlines) (repeat :tag "Yes, for TODOs in this list" (string :tag "TODO keyword")) + (list :tag "Yes, for TODOs and DONEs in these lists" + (repeat (string :tag "TODO keyword")) + (repeat (string :tag "DONE keyword"))) (other :tag "No TODO statistics" nil))) (defcustom org-hierarchical-todo-statistics t @@ -2529,7 +2847,7 @@ to change is while Emacs is running is through the customize interface." (defcustom org-treat-insert-todo-heading-as-state-change nil "Non-nil means inserting a TODO heading is treated as state change. -So when the command \\[org-insert-todo-heading] is used, state change +So when the command `\\[org-insert-todo-heading]' is used, state change logging will apply if appropriate. When nil, the new TODO item will be inserted directly, and no logging will take place." :group 'org-todo @@ -2667,20 +2985,23 @@ When nil, only the date will be recorded." (refile . "Refiled on %t") (clock-out . "")) "Headings for notes added to entries. -The value is an alist, with the car being a symbol indicating the note -context, and the cdr is the heading to be used. The heading may also be the -empty string. -%t in the heading will be replaced by a time stamp. -%T will be an active time stamp instead the default inactive one -%d will be replaced by a short-format time stamp. -%D will be replaced by an active short-format time stamp. -%s will be replaced by the new TODO state, in double quotes. -%S will be replaced by the old TODO state, in double quotes. -%u will be replaced by the user name. -%U will be replaced by the full user name. - -In fact, it is not a good idea to change the `state' entry, because -agenda log mode depends on the format of these entries." + +The value is an alist, with the car being a symbol indicating the +note context, and the cdr is the heading to be used. The heading +may also be the empty string. The following placeholders can be +used: + + %t a time stamp. + %T an active time stamp instead the default inactive one + %d a short-format time stamp. + %D an active short-format time stamp. + %s the new TODO state or time stamp (inactive), in double quotes. + %S the old TODO state or time stamp (inactive), in double quotes. + %u the user name. + %U full user name. + +In fact, it is not a good idea to change the `state' entry, +because Agenda Log mode depends on the format of these entries." :group 'org-todo :group 'org-progress :type '(list :greedy t @@ -2719,7 +3040,10 @@ If this variable is set, `org-log-state-notes-insert-after-drawers' will be ignored. You can set the property LOG_INTO_DRAWER to overrule this setting for -a subtree." +a subtree. + +Do not check directly this variable in a Lisp program. Call +function `org-log-into-drawer' instead." :group 'org-todo :group 'org-progress :type '(choice @@ -2727,18 +3051,20 @@ a subtree." (const :tag "LOGBOOK" t) (string :tag "Other"))) -(org-defvaralias 'org-log-state-notes-into-drawer 'org-log-into-drawer) +(defvaralias 'org-log-state-notes-into-drawer 'org-log-into-drawer) (defun org-log-into-drawer () - "Return the value of `org-log-into-drawer', but let properties overrule. -If the current entry has or inherits a LOG_INTO_DRAWER property, it will be -used instead of the default value." + "Name of the log drawer, as a string, or nil. +This is the value of `org-log-into-drawer'. However, if the +current entry has or inherits a LOG_INTO_DRAWER property, it will +be used instead of the default value." (let ((p (org-entry-get nil "LOG_INTO_DRAWER" 'inherit t))) - (cond - ((not p) org-log-into-drawer) - ((equal p "nil") nil) - ((equal p "t") "LOGBOOK") - (t p)))) + (cond ((equal p "nil") nil) + ((equal p "t") "LOGBOOK") + ((stringp p) p) + (p "LOGBOOK") + ((stringp org-log-into-drawer) org-log-into-drawer) + (org-log-into-drawer "LOGBOOK")))) (defcustom org-log-state-notes-insert-after-drawers nil "Non-nil means insert state change notes after any drawers in entry. @@ -2804,7 +3130,7 @@ property to one or more of these keywords." (defgroup org-priorities nil - "Priorities in Org-mode." + "Priorities in Org mode." :tag "Org Priorities" :group 'org-todo) @@ -2862,24 +3188,13 @@ as an argument and return the numeric priority." (function))) (defgroup org-time nil - "Options concerning time stamps and deadlines in Org-mode." + "Options concerning time stamps and deadlines in Org mode." :tag "Org Time" :group 'org) -(defcustom org-insert-labeled-timestamps-at-point nil - "Non-nil means SCHEDULED and DEADLINE timestamps are inserted at point. -When nil, these labeled time stamps are forces into the second line of an -entry, just after the headline. When scheduling from the global TODO list, -the time stamp will always be forced into the second line." - :group 'org-time - :type 'boolean) - -(defconst org-time-stamp-formats '("<%Y-%m-%d %a>" . "<%Y-%m-%d %a %H:%M>") - "Formats for `format-time-string' which are used for time stamps. -It is not recommended to change this constant.") - (defcustom org-time-stamp-rounding-minutes '(0 5) "Number of minutes to round time stamps to. +\\<org-mode-map>\ These are two values, the first applies when first creating a time stamp. The second applies when changing it with the commands `S-up' and `S-down'. When changing the time stamp, this means that it will change in steps @@ -2889,14 +3204,15 @@ When a setting is 0 or 1, insert the time unmodified. Useful rounding numbers should be factors of 60, so for example 5, 10, 15. When this is larger than 1, you can still force an exact time stamp by using -a double prefix argument to a time stamp command like `C-c .' or `C-c !', +a double prefix argument to a time stamp command like \ +`\\[org-time-stamp]' or `\\[org-time-stamp-inactive], and by using a prefix arg to `S-up/down' to specify the exact number of minutes to shift." :group 'org-time - :get #'(lambda (var) ; Make sure both elements are there - (if (integerp (default-value var)) - (list (default-value var) 5) - (default-value var))) + :get (lambda (var) ; Make sure both elements are there + (if (integerp (default-value var)) + (list (default-value var) 5) + (default-value var))) :type '(list (integer :tag "when inserting times") (integer :tag "when modifying times"))) @@ -3013,7 +3329,7 @@ in minutes (even for durations longer than an hour)." (const t))))) (defcustom org-time-clocksum-use-fractional nil - "When non-nil, \\[org-clock-display] uses fractional times. + "When non-nil, `\\[org-clock-display]' uses fractional times. See `org-time-clocksum-format' for more on time clock formats." :group 'org-time :group 'org-clock @@ -3021,7 +3337,7 @@ See `org-time-clocksum-format' for more on time clock formats." :type 'boolean) (defcustom org-time-clocksum-use-effort-durations nil - "When non-nil, \\[org-clock-display] uses effort durations. + "When non-nil, `\\[org-clock-display]' uses effort durations. E.g. by default, one day is considered to be a 8 hours effort, so a task that has been clocked for 16 hours will be displayed as during 2 days in the clock display or in the clocktable. @@ -3052,9 +3368,9 @@ is used." :group 'org-time :type '(choice (string :tag "Format string") (set (group :inline t (const :tag "Years" :years) - (string :tag "Format string")) + (string :tag "Format string")) (group :inline t (const :tag "Months" :months) - (string :tag "Format string")) + (string :tag "Format string")) (group :inline t (const :tag "Weeks" :weeks) (string :tag "Format string")) (group :inline t (const :tag "Days" :days) @@ -3097,8 +3413,8 @@ This affects the following situations: For example, if it is April and you enter \"feb 2\", this will be read as Feb 2, *next* year. \"May 5\", however, will be this year. 2. The user gives a day, but no month. - For example, if today is the 15th, and you enter \"3\", Org-mode will - read this as the third of *next* month. However, if you enter \"17\", + For example, if today is the 15th, and you enter \"3\", Org will read + this as the third of *next* month. However, if you enter \"17\", it will be considered as *this* month. If you set this variable to the symbol `time', then also the following @@ -3177,22 +3493,9 @@ minibuffer will also be active, and you can simply enter the date as well. When nil, only the minibuffer will be available." :group 'org-time :type 'boolean) -(org-defvaralias 'org-popup-calendar-for-date-prompt +(defvaralias 'org-popup-calendar-for-date-prompt 'org-read-date-popup-calendar) -(make-obsolete-variable - 'org-read-date-minibuffer-setup-hook - "Set `org-read-date-minibuffer-local-map' instead." "24.4") -(defcustom org-read-date-minibuffer-setup-hook nil - "Hook to be used to set up keys for the date/time interface. -Add key definitions to `minibuffer-local-map', which will be a -temporary copy. - -WARNING: This option is obsolete, you should use -`org-read-date-minibuffer-local-map' to set up keys." - :group 'org-time - :type 'hook) - (defcustom org-extend-today-until 0 "The hour when your day really ends. Must be an integer. This has influence for the following applications: @@ -3240,52 +3543,76 @@ moved to the new date." :type 'boolean) (defgroup org-tags nil - "Options concerning tags in Org-mode." + "Options concerning tags in Org mode." :tag "Org Tags" :group 'org) (defcustom org-tag-alist nil - "List of tags allowed in Org-mode files. -When this list is nil, Org-mode will base TAG input on what is already in the -buffer. -The value of this variable is an alist, the car of each entry must be a -keyword as a string, the cdr may be a character that is used to select -that tag through the fast-tag-selection interface. -See the manual for details." + "Default tags available in Org files. + +The value of this variable is an alist. Associations either: + + (TAG) + (TAG . SELECT) + (SPECIAL) + +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 +`:newline'. These keywords are used to define a hierarchy of +tags. See manual for details. + +When this variable is nil, Org mode bases tag input on what is +already in the buffer. The value can be overridden locally by +using a TAGS keyword, e.g., + + #+TAGS: tag1 tag2 + +See also `org-tag-persistent-alist' to sidestep this behavior." :group 'org-tags :type '(repeat (choice (cons (string :tag "Tag name") (character :tag "Access char")) - (list :tag "Start radio group" - (const :startgroup) - (option (string :tag "Group description"))) - (list :tag "Group tags delimiter" - (const :grouptags)) - (list :tag "End radio group" - (const :endgroup) - (option (string :tag "Group description"))) + (const :tag "Start radio group" (:startgroup)) + (const :tag "Start tag group, non distinct" (:startgrouptag)) + (const :tag "Group tags delimiter" (:grouptags)) + (const :tag "End radio group" (:endgroup)) + (const :tag "End tag group, non distinct" (:endgrouptag)) (const :tag "New line" (:newline))))) (defcustom org-tag-persistent-alist nil - "List of tags that will always appear in all Org-mode files. -This is in addition to any in buffer settings or customizations -of `org-tag-alist'. -When this list is nil, Org-mode will base TAG input on `org-tag-alist'. -The value of this variable is an alist, the car of each entry must be a -keyword as a string, the cdr may be a character that is used to select -that tag through the fast-tag-selection interface. -See the manual for details. -To disable these tags on a per-file basis, insert anywhere in the file: - #+STARTUP: noptag" + "Tags always available in Org files. + +The value of this variable is an alist. Associations either: + + (TAG) + (TAG . SELECT) + (SPECIAL) + +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 +`:newline'. These keywords are used to define a hierarchy of +tags. See manual for details. + +Unlike to `org-tag-alist', tags defined in this variable do not +depend on a local TAGS keyword. Instead, to disable these tags +on a per-file basis, insert anywhere in the file: + + #+STARTUP: noptag" :group 'org-tags :type '(repeat (choice - (cons (string :tag "Tag name") - (character :tag "Access char")) + (cons (string :tag "Tag name") + (character :tag "Access char")) (const :tag "Start radio group" (:startgroup)) + (const :tag "Start tag group, non distinct" (:startgrouptag)) (const :tag "Group tags delimiter" (:grouptags)) (const :tag "End radio group" (:endgroup)) + (const :tag "End tag group, non distinct" (:endgrouptag)) (const :tag "New line" (:newline))))) (defcustom org-complete-tags-always-offer-all-agenda-tags nil @@ -3296,9 +3623,7 @@ tags in that file can be created dynamically (there are none). (add-hook \\='org-capture-mode-hook (lambda () - (set (make-local-variable - \\='org-complete-tags-always-offer-all-agenda-tags) - t)))" + (setq-local org-complete-tags-always-offer-all-agenda-tags t)))" :group 'org-tags :version "24.1" :type 'boolean) @@ -3340,7 +3665,7 @@ displaying the tags menu is not even shown, until you press C-c again." "Non-nil means fast tags selection interface will also offer TODO states. This is an undocumented feature, you should not rely on it.") -(defcustom org-tags-column (if (featurep 'xemacs) -76 -77) +(defcustom org-tags-column -77 "The column to which tags should be indented in a headline. If this number is positive, it specifies the column. If it is negative, it means that the tags should be flushright to that column. For example, @@ -3437,7 +3762,7 @@ is better to limit inheritance to certain tags using the variables "Hook that is run after the tags in a line have changed.") (defgroup org-properties nil - "Options concerning properties in Org-mode." + "Options concerning properties in Org mode." :tag "Org Properties" :group 'org) @@ -3504,14 +3829,14 @@ in this variable)." (regexp :tag "Properties matched by regexp"))) (defun org-property-inherit-p (property) - "Check if PROPERTY is one that should be inherited." + "Return a non-nil value if PROPERTY should be inherited." (cond ((eq org-use-property-inheritance t) t) ((not org-use-property-inheritance) nil) ((stringp org-use-property-inheritance) (string-match org-use-property-inheritance property)) ((listp org-use-property-inheritance) - (member property org-use-property-inheritance)) + (member-ignore-case property org-use-property-inheritance)) (t (error "Invalid setting of `org-use-property-inheritance'")))) (defcustom org-columns-default-format "%25ITEM %TODO %3PRIORITY %TAGS" @@ -3532,26 +3857,6 @@ ellipses string, only part of the ellipses string will be shown." :group 'org-properties :type 'string) -(defcustom org-columns-modify-value-for-display-function nil - "Function that modifies values for display in column view. -For example, it can be used to cut out a certain part from a time stamp. -The function must take 2 arguments: - -column-title The title of the column (*not* the property name) -value The value that should be modified. - -The function should return the value that should be displayed, -or nil if the normal value should be used." - :group 'org-properties - :type '(choice (const nil) (function))) - -(defcustom org-effort-property "Effort" - "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." - :group 'org-properties - :group 'org-progress - :type '(string :tag "Property")) - (defconst org-global-properties-fixed '(("VISIBILITY_ALL" . "folded children content all") ("CLOCK_MODELINE_TOTAL_ALL" . "current today repeat all auto")) @@ -3582,18 +3887,17 @@ You can set buffer-local values for the same purpose in the variable (cons (string :tag "Property") (string :tag "Value")))) -(defvar org-file-properties nil +(defvar-local org-file-properties nil "List of property/value pairs that can be inherited by any entry. Valid for the current buffer. This variable is populated from #+PROPERTY lines.") -(make-variable-buffer-local 'org-file-properties) (defgroup org-agenda nil - "Options concerning agenda views in Org-mode." + "Options concerning agenda views in Org mode." :tag "Org Agenda" :group 'org) -(defvar org-category nil +(defvar-local org-category nil "Variable used by org files to set a category for agenda display. Such files should use a file variable to set it, for example @@ -3605,22 +3909,22 @@ or contain a special line If the file does not specify a category, then file's base name is used instead.") -(make-variable-buffer-local 'org-category) -(put 'org-category 'safe-local-variable #'(lambda (x) (or (symbolp x) (stringp x)))) +(put 'org-category 'safe-local-variable (lambda (x) (or (symbolp x) (stringp x)))) (defcustom org-agenda-files nil "The files to be used for agenda display. -Entries may be added to this list with \\[org-agenda-file-to-front] and removed with -\\[org-remove-file]. You can also use customize to edit the list. -If an entry is a directory, all files in that directory that are matched by -`org-agenda-file-regexp' will be part of the file list. +If an entry is a directory, all files in that directory that are matched +by `org-agenda-file-regexp' will be part of the file list. If the value of the variable is not a list but a single file name, then -the list of agenda files is actually stored and maintained in that file, one -agenda file per line. In this file paths can be given relative to +the list of agenda files is actually stored and maintained in that file, +one agenda file per line. In this file paths can be given relative to `org-directory'. Tilde expansion and environment variable substitution -are also made." +are also made. + +Entries may be added to this list with `\\[org-agenda-file-to-front]' +and removed with `\\[org-remove-file]'." :group 'org-agenda :type '(choice (repeat :tag "List of files and directories" file) @@ -3637,7 +3941,8 @@ regular expression will be included." (defcustom org-agenda-text-search-extra-files nil "List of extra files to be searched by text search commands. These files will be searched in addition to the agenda files by the -commands `org-search-view' (`C-c a s') and `org-occur-in-agenda-files'. +commands `org-search-view' (`\\[org-agenda] s') \ +and `org-occur-in-agenda-files'. Note that these files will only be searched for text search commands, not for the other agenda views like todo lists, tag searches or the weekly agenda. This variable is intended to list notes and possibly archive files @@ -3650,7 +3955,7 @@ scope." (const :tag "Agenda Archives" agenda-archives) (repeat :inline t (file)))) -(org-defvaralias 'org-agenda-multi-occur-extra-files +(defvaralias 'org-agenda-multi-occur-extra-files 'org-agenda-text-search-extra-files) (defcustom org-agenda-skip-unavailable-files nil @@ -3670,7 +3975,7 @@ forth between agenda and calendar." (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-mode file. When that is the case, the command +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 @@ -3700,7 +4005,7 @@ points to a file, `org-agenda-diary-entry' will be used instead." 'org-agenda-diary-entry)))))) (defgroup org-latex nil - "Options for embedding LaTeX code into Org-mode." + "Options for embedding LaTeX code into Org mode." :tag "Org LaTeX" :group 'org) @@ -3755,39 +4060,131 @@ Replace format-specifiers in the command as noted below and use `shell-command' to convert LaTeX to MathML. %j: Executable file in fully expanded form as specified by `org-latex-to-mathml-jar-file'. -%I: Input LaTeX file in fully expanded form -%o: Output MathML file +%I: Input LaTeX file in fully expanded form. +%i: The latex fragment to be converted. +%o: Output MathML file. + This command is used by `org-create-math-formula'. -When using MathToWeb as the converter, set this to -\"java -jar %j -unicode -force -df %o %I\"." +When using MathToWeb as the converter, set this option to +\"java -jar %j -unicode -force -df %o %I\". + +When using LaTeXML set this option to +\"latexmlmath \"%i\" --presentationmathml=%o\"." :group 'org-latex :version "24.1" :type '(choice (const :tag "None" nil) (string :tag "\nShell command"))) -(defcustom org-latex-create-formula-image-program 'dvipng - "Program to convert LaTeX fragments with. - -dvipng Process the LaTeX fragments to dvi file, then convert - dvi files to png files using dvipng. - This will also include processing of non-math environments. -imagemagick Convert the LaTeX fragments to pdf files and use imagemagick - to convert pdf files to png files" +(defcustom org-preview-latex-default-process 'dvipng + "The default process to convert LaTeX fragments to image files. +All available processes and theirs documents can be found in +`org-preview-latex-process-alist', which see." :group 'org-latex - :version "24.1" - :type '(choice - (const :tag "dvipng" dvipng) - (const :tag "imagemagick" imagemagick))) + :version "26.1" + :package-version '(Org . "9.0") + :type 'symbol) + +(defcustom org-preview-latex-process-alist + '((dvipng + :programs ("latex" "dvipng") + :description "dvi > png" + :message "you need to install the programs: latex and dvipng." + :image-input-type "dvi" + :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")) + (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) + :latex-compiler ("latex -interaction nonstopmode -output-directory %o %f") + :image-converter ("dvisvgm %f -n -b min -c %S -o %O")) + (imagemagick + :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) + :latex-compiler ("pdflatex -interaction nonstopmode -output-directory %o %f") + :image-converter + ("convert -density %D -trim -antialias %f -quality 100 %O"))) + "Definitions of external processes for LaTeX previewing. +Org mode can use some external commands to generate TeX snippet's images for +previewing or inserting into HTML files, e.g., \"dvipng\". This variable tells +`org-create-formula-image' how to call them. + +The value is an alist with the pattern (NAME . PROPERTIES). NAME is a symbol. +PROPERTIES accepts the following attributes: + + :programs list of strings, required programs. + :description string, describe the process. + :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 foregroud 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 + developers, users should use variable + `org-format-latex-options' instead. + :post-clean list of strings, files matched are to be cleaned up once + the image is generated. When nil, the files with \".dvi\", + \".xdv\", \".pdf\", \".tex\", \".aux\", \".log\", \".svg\", + \".png\", \".jpg\", \".jpeg\" or \".out\" extension will + be cleaned up. + :latex-header list of strings, the LaTeX header of the snippet file. + When nil, the fallback value is used instead, which is + controlled by `org-format-latex-header', + `org-latex-default-packages-alist' and + `org-latex-packages-alist', which see. + :latex-compiler list of LaTeX commands, as strings. Each of them is given + to the shell. Place-holders \"%t\", \"%b\" and \"%o\" are + replaced with values defined below. + :image-converter list of image converter commands strings. Each of them is + given to the shell and supports any of the following + place-holders defined below. + +Place-holders used by `:image-converter' and `:latex-compiler': + + %f input file name + %b base name of input file + %o base directory of input file + %O absolute output file name + +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." + :group 'org-latex + :version "26.1" + :package-version '(Org . "9.0") + :type '(alist :tag "LaTeX to image backends" + :value-type (plist))) -(defcustom org-latex-preview-ltxpng-directory "ltxpng/" +(defcustom org-preview-latex-image-directory "ltximg/" "Path to store latex preview images. A relative path here creates many directories relative to the processed org files paths. An absolute path puts all preview images at the same place." :group 'org-latex - :version "24.3" + :version "26.1" + :package-version '(Org . "9.0") :type 'string) (defun org-format-latex-mathml-available-p () @@ -3805,8 +4202,8 @@ images at the same place." (defcustom org-format-latex-header "\\documentclass{article} \\usepackage[usenames]{color} -[PACKAGES] -[DEFAULT-PACKAGES] +\[PACKAGES] +\[DEFAULT-PACKAGES] \\pagestyle{empty} % do not remove % The settings below are copied from fullpage.sty \\setlength{\\textwidth}{\\paperwidth} @@ -3847,22 +4244,19 @@ header, or they will be appended." (default-value var))) (defcustom org-latex-default-packages-alist - '(("AUTO" "inputenc" t) - ("T1" "fontenc" t) - ("" "fixltx2e" nil) + '(("AUTO" "inputenc" t ("pdflatex")) + ("T1" "fontenc" t ("pdflatex")) ("" "graphicx" t) + ("" "grffile" t) ("" "longtable" nil) - ("" "float" nil) ("" "wrapfig" nil) ("" "rotating" nil) ("normalem" "ulem" t) ("" "amsmath" t) ("" "textcomp" t) - ("" "marvosym" t) - ("" "wasysym" t) ("" "amssymb" t) - ("" "hyperref" nil) - "\\tolerance=1000") + ("" "capt-of" nil) + ("" "hyperref" nil)) "Alist of default packages to be inserted in the header. Change this only if one of the packages here causes an @@ -3872,16 +4266,17 @@ The packages in this list are needed by one part or another of Org mode to function properly: - inputenc, fontenc: for basic font and character selection -- fixltx2e: Important patches of LaTeX itself - graphicx: for including images +- grffile: allow periods and spaces in graphics file names - longtable: For multipage tables -- float, wrapfig: for figure placement +- wrapfig: for figure placement - rotating: for sideways figures and tables - ulem: for underline and strike-through - amsmath: for subscript and superscript and math environments -- textcomp, marvosymb, wasysym, amssymb: for various symbols used +- textcomp, amssymb: for various symbols used for interpreting the entities in `org-entities'. You can skip some of these packages if you don't use any of their symbols. +- capt-of: for captions outside of floats - hyperref: for cross references Therefore you should not modify this variable unless you know @@ -3890,20 +4285,24 @@ you might be loading some other package that conflicts with one of the default packages. Each element is either a cell or a string. -A cell is of the format: +A cell is of the format - ( \"options\" \"package\" SNIPPET-FLAG). + (\"options\" \"package\" SNIPPET-FLAG COMPILERS) 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. +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 :group 'org-export-latex :set 'org-set-packages-alist :get 'org-get-packages-alist - :version "24.1" + :version "26.1" + :package-version '(Org . "8.3") :type '(repeat (choice (list :tag "options/package pair" @@ -3947,7 +4346,7 @@ Make sure that you only list packages here which: (string :tag "A line of LaTeX")))) (defgroup org-appearance nil - "Settings for Org-mode appearance." + "Settings for Org mode appearance." :tag "Org Appearance" :group 'org) @@ -4038,6 +4437,11 @@ following symbols: :group 'org-appearance :type 'boolean) +(defcustom org-hide-macro-markers nil + "Non-nil mean font-lock should hide the brackets marking macro calls." + :group 'org-appearance + :type 'boolean) + (defcustom org-pretty-entities nil "Non-nil means show entities as UTF8 characters. When nil, the \\name form remains in the buffer." @@ -4124,7 +4528,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) + '(" \t('\"{" "- \t.,:!?;'\")}\\[" " \t\r\n" "." 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 @@ -4142,17 +4546,17 @@ newline The maximum number of newlines allowed in an emphasis exp. You need to reload Org or to restart Emacs after customizing this.") (defcustom org-emphasis-alist - `(("*" bold) + '(("*" bold) ("/" italic) ("_" underline) ("=" org-verbatim verbatim) ("~" org-code verbatim) - ("+" ,(if (featurep 'xemacs) 'org-table '(:strike-through t)))) + ("+" (:strike-through t))) "Alist of characters and faces to emphasize text. Text starting and ending with a special character will be emphasized, for example *bold*, _underlined_ and /italic/. This variable sets the marker characters and the face to be used by font-lock for highlighting -in Org-mode Emacs buffers. +in Org buffers. You need to reload Org or to restart Emacs after customizing this." :group 'org-appearance @@ -4167,122 +4571,68 @@ You need to reload Org or to restart Emacs after customizing this." (plist :tag "Face property list")) (option (const verbatim))))) -(defvar org-protecting-blocks - '("src" "example" "latex" "ascii" "html" "ditaa" "dot" "r" "R") +(defvar org-protecting-blocks '("src" "example" "export") "Blocks that contain text that is quoted, i.e. not processed as Org syntax. This is needed for font-lock setup.") -;;; Miscellaneous options - -(defgroup org-completion nil - "Completion in Org-mode." - :tag "Org Completion" - :group 'org) - -(defcustom org-completion-use-ido nil - "Non-nil means use ido completion wherever possible. -Note that `ido-mode' must be active for this variable to be relevant. -If you decide to turn this variable on, you might well want to turn off -`org-outline-path-complete-in-steps'. -See also `org-completion-use-iswitchb'." - :group 'org-completion - :type 'boolean) - -(defcustom org-completion-use-iswitchb nil - "Non-nil means use iswitchb completion wherever possible. -Note that `iswitchb-mode' must be active for this variable to be relevant. -If you decide to turn this variable on, you might well want to turn off -`org-outline-path-complete-in-steps'. -Note that this variable has only an effect if `org-completion-use-ido' is nil." - :group 'org-completion - :type 'boolean) - -(defcustom org-completion-fallback-command 'hippie-expand - "The expansion command called by \\[pcomplete] in normal context. -Normal means, no org-mode-specific context." - :group 'org-completion - :type 'function) - ;;; Functions and variables from their packages ;; Declared here to avoid compiler warnings - -;; XEmacs only -(defvar outline-mode-menu-heading) -(defvar outline-mode-menu-show) -(defvar outline-mode-menu-hide) -(defvar zmacs-regions) ; XEmacs regions - -;; Emacs only (defvar mark-active) ;; Various packages -(declare-function calendar-iso-to-absolute "cal-iso" (date)) -(declare-function calendar-forward-day "cal-move" (arg)) -(declare-function calendar-goto-date "cal-move" (date)) -(declare-function calendar-goto-today "cal-move" ()) -(declare-function calendar-iso-from-absolute "cal-iso" (date)) -(defvar calc-embedded-close-formula) -(defvar calc-embedded-open-formula) -(declare-function cdlatex-tab "ext:cdlatex" ()) +(declare-function calc-eval "calc" (str &optional separator &rest args)) +(declare-function calendar-forward-day "cal-move" (arg)) +(declare-function calendar-goto-date "cal-move" (date)) +(declare-function calendar-goto-today "cal-move" ()) +(declare-function calendar-iso-from-absolute "cal-iso" (date)) +(declare-function calendar-iso-to-absolute "cal-iso" (date)) (declare-function cdlatex-compute-tables "ext:cdlatex" ()) -(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) -(defvar font-lock-unfontify-region-function) -(declare-function iswitchb-read-buffer "iswitchb" - (prompt &optional - default require-match _predicate start matches-set)) -(defvar iswitchb-temp-buflist) -(declare-function org-gnus-follow-link "org-gnus" (&optional group article)) -(defvar org-agenda-tags-todo-honor-ignore-options) -(declare-function org-agenda-skip "org-agenda" ()) -(declare-function - org-agenda-format-item "org-agenda" - (extra txt &optional level category tags dotime remove-re habitp)) -(declare-function org-agenda-new-marker "org-agenda" (&optional pos)) -(declare-function org-agenda-change-all-lines "org-agenda" +(declare-function cdlatex-tab "ext:cdlatex" ()) +(declare-function dired-get-filename + "dired" + (&optional localp no-error-if-not-filep)) +(declare-function iswitchb-read-buffer + "iswitchb" + (prompt &optional + default require-match _predicate start matches-set)) +(declare-function org-agenda-change-all-lines + "org-agenda" (newhead hdmarker &optional fixface just-this)) -(declare-function org-agenda-set-restriction-lock "org-agenda" (&optional type)) +(declare-function org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item + "org-agenda" + (&optional end)) +(declare-function org-agenda-copy-local-variable "org-agenda" (var)) +(declare-function org-agenda-format-item + "org-agenda" + (extra txt &optional level category tags dotime + remove-re habitp)) (declare-function org-agenda-maybe-redo "org-agenda" ()) -(declare-function org-agenda-save-markers-for-cut-and-paste "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-copy-local-variable "org-agenda" (var)) -(declare-function org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item - "org-agenda" (&optional end)) -(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) -(declare-function org-inlinetask-in-task-p "org-inlinetask" ()) +(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-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-indent-mode "org-indent" (&optional arg)) -(declare-function parse-time-string "parse-time" (string)) -(declare-function org-attach-reveal "org-attach" (&optional if-exists)) +(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)) -(defvar remember-data-file) -(defvar texmathp-why) +(declare-function parse-time-string "parse-time" (string)) (declare-function speedbar-line-directory "speedbar" (&optional depth)) -(declare-function table--at-cell-p "table" (position &optional object at-column)) - -(defvar org-latex-regexps) -;;; Autoload and prepare some org modules - -;; Some table stuff that needs to be defined here, because it is used -;; by the functions setting up org-mode or checking for table context. - -(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 align-mode-rules-list) +(defvar calc-embedded-close-formula) +(defvar calc-embedded-open-formula) +(defvar calc-embedded-open-mode) +(defvar font-lock-unfontify-region-function) +(defvar iswitchb-temp-buflist) +(defvar org-agenda-tags-todo-honor-ignore-options) +(defvar remember-data-file) +(defvar texmathp-why) ;;;###autoload (defun turn-on-orgtbl () @@ -4291,75 +4641,50 @@ This works for both table types.") (orgtbl-mode 1)) (defun org-at-table-p (&optional table-type) - "Return t if the cursor is inside an org-type table. -If TABLE-TYPE is non-nil, also check for table.el-type tables." - (if org-enable-table-editor - (save-excursion - (beginning-of-line 1) - (looking-at (if table-type org-table-any-line-regexp - org-table-line-regexp))) - nil)) -(defsubst org-table-p () (org-at-table-p)) + "Non-nil if the cursor is inside an Org table. +If TABLE-TYPE is non-nil, also check for table.el-type tables. +If `org-enable-table-editor' is nil, return nil unconditionally." + (and + org-enable-table-editor + (save-excursion + (beginning-of-line) + (looking-at-p (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-element-property :type e) 'org))))))) (defun org-at-table.el-p () - "Return t if and only if we are at a table.el table." - (and (org-at-table-p 'any) - (save-excursion - (goto-char (org-table-begin 'any)) - (looking-at org-table1-hline-regexp)))) - -(defun org-table-recognize-table.el () - "If there is a table.el table nearby, recognize it and move into it." - (if org-table-tab-recognizes-table.el - (if (org-at-table.el-p) - (progn - (beginning-of-line 1) - (if (looking-at org-table-dataline-regexp) - nil - (if (looking-at org-table1-hline-regexp) - (progn - (beginning-of-line 2) - (if (looking-at org-table-any-border-regexp) - (beginning-of-line -1))))) - (if (re-search-forward "|" (org-table-end t) t) - (progn - (require 'table) - (if (table--at-cell-p (point)) - t - (message "recognizing table.el table...") - (table-recognize-table) - (message "recognizing table.el table...done"))) - (error "This should not happen")) - t) - nil) - nil)) + "Non-nil when point is at a table.el table." + (and (save-excursion (beginning-of-line) (looking-at "[ \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 () - "Return t if the cursor is inside a hline in a table." - (if org-enable-table-editor - (save-excursion - (beginning-of-line 1) - (looking-at org-table-hline-regexp)) - nil)) + "Non-nil when point is inside a hline in a table. +Assume point is already in a table. If `org-enable-table-editor' +is nil, return nil unconditionally." + (and org-enable-table-editor + (save-excursion + (beginning-of-line) + (looking-at org-table-hline-regexp)))) (defun org-table-map-tables (function &optional quietly) "Apply FUNCTION to the start of all tables in the buffer." - (save-excursion - (save-restriction - (widen) - (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)))) + (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)) @@ -4368,12 +4693,12 @@ If TABLE-TYPE is non-nil, also check for table.el-type tables." (&optional also-non-dangling-p prompt last-valid)) (defun org-at-TBLFM-p (&optional pos) - "Return t when point (or POS) is in #+TBLFM line." + "Non-nil when point (or POS) is in #+TBLFM line." (save-excursion - (let ((pos pos))) (goto-char (or pos (point))) - (beginning-of-line 1) - (looking-at org-TBLFM-regexp))) + (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) @@ -4410,7 +4735,7 @@ If yes, offer to stop it and to save the buffer with the changes." (add-hook 'kill-emacs-hook 'org-clock-save)) (defgroup org-archive nil - "Options concerning archiving in Org-mode." + "Options concerning archiving in Org mode." :tag "Org Archive" :group 'org-structure) @@ -4425,7 +4750,7 @@ When the filename is omitted, archiving happens in the same file. %s in the filename will be replaced by the current file name (without the directory part). Archiving to a different file is useful to keep archived entries from contributing to the -Org-mode Agenda. +Org Agenda. The archived entries will be filed as subtrees of the specified headline. When the headline is omitted, the subtrees are simply @@ -4473,16 +4798,6 @@ the hierarchy, it will be used." :group 'org-archive :type 'string) -(defcustom org-archive-tag "ARCHIVE" - "The tag that marks a subtree as archived. -An archived subtree does not open during visibility cycling, and does -not contribute to the agenda listings. -After changing this, font-lock must be restarted in the relevant buffers to -get the proper fontification." - :group 'org-archive - :group 'org-keywords - :type 'string) - (defcustom org-agenda-skip-archived-trees t "Non-nil means the agenda will skip any items located in archived trees. An archived tree is a tree marked with the tag ARCHIVE. The use of this @@ -4515,24 +4830,25 @@ collapsed state." :group 'org-sparse-trees :type 'boolean) -(defcustom org-sparse-tree-default-date-type 'scheduled-or-deadline +(defcustom org-sparse-tree-default-date-type nil "The default date type when building a sparse tree. When this is nil, a date is a scheduled or a deadline timestamp. Otherwise, these types are allowed: all: all timestamps active: only active timestamps (<...>) - inactive: only inactive timestamps (<...) + inactive: only inactive timestamps ([...]) scheduled: only scheduled timestamps deadline: only deadline timestamps" - :type '(choice (const :tag "Scheduled or deadline" scheduled-or-deadline) + :type '(choice (const :tag "Scheduled or deadline" nil) (const :tag "All timestamps" all) (const :tag "Only active timestamps" active) (const :tag "Only inactive timestamps" inactive) (const :tag "Only scheduled timestamps" scheduled) (const :tag "Only deadline timestamps" deadline) (const :tag "Only closed timestamps" closed)) - :version "24.3" + :version "26.1" + :package-version '(Org . "8.3") :group 'org-sparse-trees) (defun org-cycle-hide-archived-subtrees (state) @@ -4545,9 +4861,10 @@ Otherwise, these types are allowed: (end (if globalp (point-max) (org-end-of-subtree t)))) (org-hide-archived-subtrees beg end) (goto-char beg) - (if (looking-at (concat ".*:" org-archive-tag ":")) - (message "%s" (substitute-command-keys - "Subtree is archived and stays closed. Use \\[org-force-cycle-archived] to cycle it anyway."))))))) + (when (looking-at-p (concat ".*:" org-archive-tag ":")) + (message "%s" (substitute-command-keys + "Subtree is archived and stays closed. Use \ +`\\[org-force-cycle-archived]' to cycle it anyway."))))))) (defun org-force-cycle-archived () "Cycle subtree even if it is archived." @@ -4558,13 +4875,16 @@ Otherwise, these types are allowed: (defun org-hide-archived-subtrees (beg end) "Re-hide all archived subtrees after a visibility state change." - (save-excursion - (let* ((re (concat ":" org-archive-tag ":"))) - (goto-char beg) - (while (re-search-forward re end t) - (when (org-at-heading-p) - (org-flag-subtree t) - (org-end-of-subtree t)))))) + (org-with-wide-buffer + (let ((case-fold-search nil) + (re (concat org-outline-regexp-bol ".*:" org-archive-tag ":"))) + (goto-char beg) + ;; 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)) + (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)) @@ -4580,7 +4900,6 @@ Otherwise, these types are allowed: ;; Declare Column View Code -(declare-function org-columns-number-to-string "org-colview" (n fmt &optional printf)) (declare-function org-columns-get-format-and-top-level "org-colview" ()) (declare-function org-columns-compute "org-colview" (property)) @@ -4593,79 +4912,47 @@ Otherwise, these types are allowed: ;;; Variables for pre-computed regular expressions, all buffer local -(defvar org-drawer-regexp "^[ \t]*:PROPERTIES:[ \t]*$" - "Matches first line of a hidden block.") -(make-variable-buffer-local 'org-drawer-regexp) -(defvar org-todo-regexp nil - "Matches any of the TODO state keywords.") -(make-variable-buffer-local 'org-todo-regexp) -(defvar org-not-done-regexp nil - "Matches any of the TODO state keywords except the last one.") -(make-variable-buffer-local 'org-not-done-regexp) -(defvar org-not-done-heading-regexp nil - "Matches a TODO headline that is not done.") -(make-variable-buffer-local 'org-not-done-regexp) -(defvar org-todo-line-regexp nil - "Matches a headline and puts TODO state into group 2 if present.") -(make-variable-buffer-local 'org-todo-line-regexp) -(defvar org-complex-heading-regexp nil +(defvar-local org-todo-regexp nil + "Matches any of the TODO state keywords. +Since TODO keywords are case-sensitive, `case-fold-search' is +expected to be bound to nil when matching against this regexp.") + +(defvar-local org-not-done-regexp nil + "Matches any of the TODO state keywords except the last one. +Since TODO keywords are case-sensitive, `case-fold-search' is +expected to be bound to nil when matching against this regexp.") + +(defvar-local org-not-done-heading-regexp nil + "Matches a TODO headline that is not done. +Since TODO keywords are case-sensitive, `case-fold-search' is +expected to be bound to nil when matching against this regexp.") + +(defvar-local org-todo-line-regexp nil + "Matches a headline and puts TODO state into group 2 if present. +Since TODO keywords are case-sensitive, `case-fold-search' is +expected to be bound to nil when matching against this regexp.") + +(defvar-local org-complex-heading-regexp nil "Matches a headline and puts everything into groups: -group 1: the stars -group 2: The todo keyword, maybe + +group 1: Stars +group 2: The TODO keyword, maybe group 3: Priority cookie group 4: True headline -group 5: Tags") -(make-variable-buffer-local 'org-complex-heading-regexp) -(defvar org-complex-heading-regexp-format nil +group 5: Tags + +Since TODO keywords are case-sensitive, `case-fold-search' is +expected to be bound to nil when matching against this regexp.") + +(defvar-local org-complex-heading-regexp-format nil "Printf format to make regexp to match an exact headline. This regexp will match the headline of any node which has the exact headline text that is put into the format, but may have any TODO state, priority and tags.") -(make-variable-buffer-local 'org-complex-heading-regexp-format) -(defvar org-todo-line-tags-regexp nil + +(defvar-local org-todo-line-tags-regexp nil "Matches a headline and puts TODO state into group 2 if present. Also put tags into group 4 if tags are present.") -(make-variable-buffer-local 'org-todo-line-tags-regexp) -(defvar org-ds-keyword-length 12 - "Maximum length of the DEADLINE and SCHEDULED keywords.") -(make-variable-buffer-local 'org-ds-keyword-length) -(defvar org-deadline-regexp nil - "Matches the DEADLINE keyword.") -(make-variable-buffer-local 'org-deadline-regexp) -(defvar org-deadline-time-regexp nil - "Matches the DEADLINE keyword together with a time stamp.") -(make-variable-buffer-local 'org-deadline-time-regexp) -(defvar org-deadline-time-hour-regexp nil - "Matches the DEADLINE keyword together with a time-and-hour stamp.") -(make-variable-buffer-local 'org-deadline-time-hour-regexp) -(defvar org-deadline-line-regexp nil - "Matches the DEADLINE keyword and the rest of the line.") -(make-variable-buffer-local 'org-deadline-line-regexp) -(defvar org-scheduled-regexp nil - "Matches the SCHEDULED keyword.") -(make-variable-buffer-local 'org-scheduled-regexp) -(defvar org-scheduled-time-regexp nil - "Matches the SCHEDULED keyword together with a time stamp.") -(make-variable-buffer-local 'org-scheduled-time-regexp) -(defvar org-scheduled-time-hour-regexp nil - "Matches the SCHEDULED keyword together with a time-and-hour stamp.") -(make-variable-buffer-local 'org-scheduled-time-hour-regexp) -(defvar org-closed-time-regexp nil - "Matches the CLOSED keyword together with a time stamp.") -(make-variable-buffer-local 'org-closed-time-regexp) - -(defvar org-keyword-time-regexp nil - "Matches any of the 4 keywords, together with the time stamp.") -(make-variable-buffer-local 'org-keyword-time-regexp) -(defvar org-keyword-time-not-clock-regexp nil - "Matches any of the 3 keywords, together with the time stamp.") -(make-variable-buffer-local 'org-keyword-time-not-clock-regexp) -(defvar org-maybe-keyword-time-regexp nil - "Matches a timestamp, possibly preceded by a keyword.") -(make-variable-buffer-local 'org-maybe-keyword-time-regexp) -(defvar org-all-time-keywords nil - "List of time keywords.") -(make-variable-buffer-local 'org-all-time-keywords) (defconst org-plain-time-of-day-regexp (concat @@ -4771,32 +5058,6 @@ in the #+STARTUP line), the corresponding variable, and the value to set this variable to if the option is found. An optional forth element PUSH means to push this value onto the list in the variable.") -(defun org-update-property-plist (key val props) - "Update PROPS with KEY and VAL." - (let* ((appending (string= "+" (substring key (- (length key) 1)))) - (key (if appending (substring key 0 (- (length key) 1)) key)) - (remainder (org-remove-if (lambda (p) (string= (car p) key)) props)) - (previous (cdr (assoc key props)))) - (if appending - (cons (cons key (if previous (concat previous " " val) val)) remainder) - (cons (cons key val) remainder)))) - -(defconst org-block-regexp - "^[ \t]*#\\+begin_?\\([^ \n]+\\)\\(\\([^\n]+\\)\\)?\n\\([^\000]+?\\)#\\+end_?\\1[ \t]*$" - "Regular expression for hiding blocks.") -(defconst org-heading-keyword-regexp-format - "^\\(\\*+\\)\\(?: +%s\\)\\(?: +\\(.*?\\)\\)?[ \t]*$" - "Printf format for a regexp matching a headline with some keyword. -This regexp will match the headline of any node which has the -exact keyword that is put into the format. The keyword isn't in -any group by default, but the stars and the body are.") -(defconst org-heading-keyword-maybe-regexp-format - "^\\(\\*+\\)\\(?: +%s\\)?\\(?: +\\(.*?\\)\\)?[ \t]*$" - "Printf format for a regexp matching a headline, possibly with some keyword. -This regexp can match any headline with the specified keyword, or -without a keyword. The keyword isn't in any group by default, -but the stars and the body are.") - (defcustom org-group-tags t "When non-nil (the default), use group tags. This can be turned on/off through `org-toggle-tags-groups'." @@ -4820,386 +5081,378 @@ 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-set-regexps-and-options-for-tags () - "Precompute variables used for tags." +(defun org-set-regexps-and-options (&optional tags-only) + "Precompute regular expressions used in the current buffer. +When optional argument TAGS-ONLY is non-nil, only compute tags +related expressions." (when (derived-mode-p 'org-mode) - (org-set-local 'org-file-tags nil) - (let ((re (org-make-options-regexp '("FILETAGS" "TAGS"))) - (splitre "[ \t]+") - (start 0) - tags ftags key value) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (setq key (upcase (org-match-string-no-properties 1)) - value (org-match-string-no-properties 2)) - (if (stringp value) (setq value (org-trim value))) - (cond - ((equal key "TAGS") - (setq tags (append tags (if tags '("\\n") nil) - (org-split-string value splitre)))) - ((equal key "FILETAGS") - (when (string-match "\\S-" value) - (setq ftags - (append - ftags - (apply 'append - (mapcar (lambda (x) (org-split-string x ":")) - (org-split-string value))))))))))) - ;; Process the file tags. - (and ftags (org-set-local 'org-file-tags - (mapcar 'org-add-prop-inherited ftags))) - (org-set-local 'org-tag-groups-alist nil) - ;; Process the tags. - (when (and (not tags) org-tag-alist) - (setq tags - (mapcar - (lambda (tg) (cond ((eq (car tg) :startgroup) "{") - ((eq (car tg) :endgroup) "}") - ((eq (car tg) :grouptags) ":") - ((eq (car tg) :newline) "\n") - (t (concat (car tg) - (if (characterp (cdr tg)) - (format "(%s)" (char-to-string (cdr tg))) ""))))) - org-tag-alist))) - (let (tgs g) - (dolist (e tags) - (cond - ((equal e "{") - (progn (push '(:startgroup) tgs) - (when (equal (nth 1 tags) ":") - (push (list (replace-regexp-in-string - "(.+)$" "" (nth 0 tags))) - org-tag-groups-alist) - (setq g 0)))) - ((equal e ":") (push '(:grouptags) tgs)) - ((equal e "}") (push '(:endgroup) tgs) (if g (setq g nil))) - ((equal e "\\n") (push '(:newline) tgs)) - ((string-match (org-re "^\\([[:alnum:]_@#%]+\\)(\\(.\\))$") e) - (push (cons (match-string 1 e) - (string-to-char (match-string 2 e))) - tgs) - (if (and g (> g 0)) - (setcar org-tag-groups-alist - (append (car org-tag-groups-alist) - (list (match-string 1 e))))) - (if g (setq g (1+ g)))) - (t (push (list e) tgs) - (if (and g (> g 0)) - (setcar org-tag-groups-alist - (append (car org-tag-groups-alist) (list e)))) - (if g (setq g (1+ g)))))) - (org-set-local 'org-tag-alist nil) - (dolist (e tgs) - (or (and (stringp (car e)) - (assoc (car e) org-tag-alist)) - (push e org-tag-alist))) - ;; Return a list with tag variables - (list org-file-tags org-tag-alist org-tag-groups-alist))))) - -(defvar org-ota nil) -(defun org-set-regexps-and-options () - "Precompute regular expressions used in the current buffer." - (when (derived-mode-p 'org-mode) - (org-set-local 'org-todo-kwd-alist nil) - (org-set-local 'org-todo-key-alist nil) - (org-set-local 'org-todo-key-trigger nil) - (org-set-local 'org-todo-keywords-1 nil) - (org-set-local 'org-done-keywords nil) - (org-set-local 'org-todo-heads nil) - (org-set-local 'org-todo-sets nil) - (org-set-local 'org-todo-log-states nil) - (org-set-local 'org-file-properties nil) - (let ((re (org-make-options-regexp - '("CATEGORY" "TODO" "COLUMNS" "STARTUP" "ARCHIVE" - "LINK" "PRIORITIES" "CONSTANTS" "PROPERTY" "DRAWERS" - "SETUPFILE" "OPTIONS") - "\\(?:[a-zA-Z][0-9a-zA-Z_]*_TODO\\)")) - (splitre "[ \t]+") - (scripts org-use-sub-superscripts) - kwds kws0 kwsa key log value cat arch const links hw dws - tail sep kws1 prio props drawers ext-setup-or-nil setup-contents - (start 0)) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while - (or (and - ext-setup-or-nil - (not org-ota) - (let (ret) - (with-temp-buffer - (insert ext-setup-or-nil) - (let ((major-mode 'org-mode) org-ota) - (setq ret (save-match-data - (org-set-regexps-and-options-for-tags))))) - ;; Append setupfile tags to existing tags - (setq org-ota t) - (setq org-file-tags - (delq nil (append org-file-tags (nth 0 ret))) - org-tag-alist - (delq nil (append org-tag-alist (nth 1 ret))) - org-tag-groups-alist - (delq nil (append org-tag-groups-alist (nth 2 ret)))))) - (and ext-setup-or-nil - (string-match re ext-setup-or-nil start) - (setq start (match-end 0))) - (and (setq ext-setup-or-nil nil start 0) - (re-search-forward re nil t))) - (setq key (upcase (match-string 1 ext-setup-or-nil)) - value (org-match-string-no-properties 2 ext-setup-or-nil)) - (if (stringp value) (setq value (org-trim value))) - (cond - ((equal key "CATEGORY") - (setq cat value)) - ((member key '("SEQ_TODO" "TODO")) - (push (cons 'sequence (org-split-string value splitre)) kwds)) - ((equal key "TYP_TODO") - (push (cons 'type (org-split-string value splitre)) kwds)) - ((string-match "\\`\\([a-zA-Z][0-9a-zA-Z_]*\\)_TODO\\'" key) - ;; general TODO-like setup - (push (cons (intern (downcase (match-string 1 key))) - (org-split-string value splitre)) - kwds)) - ((equal key "COLUMNS") - (org-set-local 'org-columns-default-format value)) - ((equal key "LINK") - (when (string-match "^\\(\\S-+\\)[ \t]+\\(.+\\)" value) - (push (cons (match-string 1 value) - (org-trim (match-string 2 value))) - links))) - ((equal key "PRIORITIES") - (setq prio (org-split-string value " +"))) - ((equal key "PROPERTY") - (when (string-match "\\(\\S-+\\)\\s-+\\(.*\\)" value) - (setq props (org-update-property-plist (match-string 1 value) - (match-string 2 value) - props)))) - ((equal key "DRAWERS") - (setq drawers (delete-dups (append org-drawers (org-split-string value splitre))))) - ((equal key "CONSTANTS") - (org-table-set-constants)) - ((equal key "STARTUP") - (let ((opts (org-split-string value splitre)) - var val) - (dolist (l opts) - (when (setq l (assoc l org-startup-options)) - (setq var (nth 1 l) val (nth 2 l)) - (if (not (nth 3 l)) - (set (make-local-variable var) val) - (if (not (listp (symbol-value var))) - (set (make-local-variable var) nil)) - (set (make-local-variable var) (symbol-value var)) - (add-to-list var val)))))) - ((equal key "ARCHIVE") - (setq arch value) - (remove-text-properties 0 (length arch) - '(face t fontified t) arch)) - ((equal key "OPTIONS") - (if (string-match "\\([ \t]\\|\\`\\)\\^:\\(t\\|nil\\|{}\\)" value) - (setq scripts (read (match-string 2 value))))) - ((and (equal key "SETUPFILE") - ;; Prevent checking in Gnus messages - (not buffer-read-only)) - (setq setup-contents (org-file-contents - (expand-file-name - (org-remove-double-quotes value)) - 'noerror)) - (if (not ext-setup-or-nil) - (setq ext-setup-or-nil setup-contents start 0) - (setq ext-setup-or-nil - (concat (substring ext-setup-or-nil 0 start) - "\n" setup-contents "\n" - (substring ext-setup-or-nil start))))))) - ;; search for property blocks - (goto-char (point-min)) - (while (re-search-forward org-block-regexp nil t) - (when (equal "PROPERTY" (upcase (match-string 1))) - (setq value (replace-regexp-in-string - "[\n\r]" " " (match-string 4))) - (when (string-match "\\(\\S-+\\)\\s-+\\(.*\\)" value) - (setq props (org-update-property-plist (match-string 1 value) - (match-string 2 value) - props))))))) - (org-set-local 'org-use-sub-superscripts scripts) - (when cat - (org-set-local 'org-category (intern cat)) - (push (cons "CATEGORY" cat) props)) - (when prio - (if (< (length prio) 3) (setq prio '("A" "C" "B"))) - (setq prio (mapcar 'string-to-char prio)) - (org-set-local 'org-highest-priority (nth 0 prio)) - (org-set-local 'org-lowest-priority (nth 1 prio)) - (org-set-local 'org-default-priority (nth 2 prio))) - (and props (org-set-local 'org-file-properties (nreverse props))) - (and drawers (org-set-local 'org-drawers drawers)) - (and arch (org-set-local 'org-archive-location arch)) - (and links (setq org-link-abbrev-alist-local (nreverse links))) - ;; Process the TODO keywords - (unless kwds - ;; Use the global values as if they had been given locally. - (setq kwds (default-value 'org-todo-keywords)) - (if (stringp (car kwds)) - (setq kwds (list (cons org-todo-interpretation - (default-value 'org-todo-keywords))))) - (setq kwds (reverse kwds))) - (setq kwds (nreverse kwds)) - (let (inter kw) - (dolist (kws kwds) - (let ((kws (or - (run-hook-with-args-until-success - 'org-todo-setup-filter-hook kws) - kws))) - (setq inter (pop kws) sep (member "|" kws) - kws0 (delete "|" (copy-sequence kws)) - kwsa nil - kws1 (mapcar - (lambda (x) - ;; 1 2 - (if (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$" x) - (progn - (setq kw (match-string 1 x) - key (and (match-end 2) (match-string 2 x)) - log (org-extract-log-state-settings x)) - (push (cons kw (and key (string-to-char key))) kwsa) - (and log (push log org-todo-log-states)) - kw) - (error "Invalid TODO keyword %s" x))) - kws0) - kwsa (if kwsa (append '((:startgroup)) - (nreverse kwsa) - '((:endgroup)))) - hw (car kws1) - dws (if sep (org-remove-keyword-keys (cdr sep)) (last kws1)) - tail (list inter hw (car dws) (org-last dws)))) - (add-to-list 'org-todo-heads hw 'append) - (push kws1 org-todo-sets) - (setq org-done-keywords (append org-done-keywords dws nil)) - (setq org-todo-key-alist (append org-todo-key-alist kwsa)) - (mapc (lambda (x) (push (cons x tail) org-todo-kwd-alist)) kws1) - (setq org-todo-keywords-1 (append org-todo-keywords-1 kws1 nil))) + (let ((alist (org--setup-collect-keywords + (org-make-options-regexp + (append '("FILETAGS" "TAGS" "SETUPFILE") + (and (not tags-only) + '("ARCHIVE" "CATEGORY" "COLUMNS" "CONSTANTS" + "LINK" "OPTIONS" "PRIORITIES" "PROPERTY" + "SEQ_TODO" "STARTUP" "TODO" "TYP_TODO"))))))) + ;; Startup options. Get this early since it does change + ;; behavior for other options (e.g., tags). + (let ((startup (cdr (assq 'startup alist)))) + (dolist (option startup) + (let ((entry (assoc-string option org-startup-options t))) + (when entry + (let ((var (nth 1 entry)) + (val (nth 2 entry))) + (if (not (nth 3 entry)) (set (make-local-variable var) val) + (unless (listp (symbol-value var)) + (set (make-local-variable var) nil)) + (add-to-list var val))))))) + (setq-local org-file-tags + (mapcar #'org-add-prop-inherited + (cdr (assq 'filetags alist)))) + (setq org-current-tag-alist + (append org-tag-persistent-alist + (let ((tags (cdr (assq 'tags alist)))) + (if tags (org-tag-string-to-alist tags) + org-tag-alist)))) + (setq org-tag-groups-alist + (org-tag-alist-to-groups org-current-tag-alist)) + (unless tags-only + ;; File properties. + (setq-local org-file-properties (cdr (assq 'property alist))) + ;; Archive location. + (let ((archive (cdr (assq 'archive alist)))) + (when archive (setq-local org-archive-location archive))) + ;; Category. + (let ((cat (org-string-nw-p (cdr (assq 'category alist))))) + (when cat + (setq-local org-category (intern cat)) + (setq-local org-file-properties + (org--update-property-plist + "CATEGORY" cat org-file-properties)))) + ;; Columns. + (let ((column (cdr (assq 'columns alist)))) + (when column (setq-local org-columns-default-format column))) + ;; Constants. + (setq org-table-formula-constants-local (cdr (assq 'constants alist))) + ;; Link abbreviations. + (let ((links (cdr (assq 'link alist)))) + (when links (setq org-link-abbrev-alist-local (nreverse links)))) + ;; Priorities. + (let ((priorities (cdr (assq 'priorities alist)))) + (when priorities + (setq-local org-highest-priority (nth 0 priorities)) + (setq-local org-lowest-priority (nth 1 priorities)) + (setq-local org-default-priority (nth 2 priorities)))) + ;; Scripts. + (let ((scripts (assq 'scripts alist))) + (when scripts + (setq-local org-use-sub-superscripts (cdr scripts)))) + ;; TODO keywords. + (setq-local org-todo-kwd-alist nil) + (setq-local org-todo-key-alist nil) + (setq-local org-todo-key-trigger nil) + (setq-local org-todo-keywords-1 nil) + (setq-local org-done-keywords nil) + (setq-local org-todo-heads nil) + (setq-local org-todo-sets nil) + (setq-local org-todo-log-states nil) + (let ((todo-sequences + (or (nreverse (cdr (assq 'todo alist))) + (let ((d (default-value 'org-todo-keywords))) + (if (not (stringp (car d))) d + ;; XXX: Backward compatibility code. + (list (cons org-todo-interpretation d))))))) + (dolist (sequence todo-sequences) + (let* ((sequence (or (run-hook-with-args-until-success + 'org-todo-setup-filter-hook sequence) + sequence)) + (sequence-type (car sequence)) + (keywords (cdr sequence)) + (sep (member "|" keywords)) + names alist) + (dolist (k (remove "|" keywords)) + (unless (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$" + k) + (error "Invalid TODO keyword %s" k)) + (let ((name (match-string 1 k)) + (key (match-string 2 k)) + (log (org-extract-log-state-settings k))) + (push name names) + (push (cons name (and key (string-to-char key))) alist) + (when log (push log org-todo-log-states)))) + (let* ((names (nreverse names)) + (done (if sep (org-remove-keyword-keys (cdr sep)) + (last names))) + (head (car names)) + (tail (list sequence-type head (car done) (org-last done)))) + (add-to-list 'org-todo-heads head 'append) + (push names org-todo-sets) + (setq org-done-keywords (append org-done-keywords done nil)) + (setq org-todo-keywords-1 (append org-todo-keywords-1 names nil)) + (setq org-todo-key-alist + (append org-todo-key-alist + (and alist + (append '((:startgroup)) + (nreverse alist) + '((:endgroup)))))) + (dolist (k names) (push (cons k tail) org-todo-kwd-alist)))))) (setq org-todo-sets (nreverse org-todo-sets) org-todo-kwd-alist (nreverse org-todo-kwd-alist) - org-todo-key-trigger (delq nil (mapcar 'cdr org-todo-key-alist)) - org-todo-key-alist (org-assign-fast-keys org-todo-key-alist))) - ;; Compute the regular expressions and other local variables. - ;; Using `org-outline-regexp-bol' would complicate them much, - ;; because of the fixed white space at the end of that string. - (if (not org-done-keywords) - (setq org-done-keywords (and org-todo-keywords-1 - (list (org-last org-todo-keywords-1))))) - (setq org-ds-keyword-length (+ 2 (max (length org-deadline-string) - (length org-scheduled-string) - (length org-clock-string) - (length org-closed-string))) - org-drawer-regexp - (concat "^[ \t]*:\\(" - (mapconcat 'regexp-quote org-drawers "\\|") - "\\):[ \t]*$") - org-not-done-keywords - (org-delete-all org-done-keywords (copy-sequence org-todo-keywords-1)) - org-todo-regexp - (concat "\\(" - (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") - "\\)") - org-not-done-regexp - (concat "\\(" - (mapconcat 'regexp-quote org-not-done-keywords "\\|") - "\\)") - org-not-done-heading-regexp - (format org-heading-keyword-regexp-format org-not-done-regexp) - org-todo-line-regexp - (format org-heading-keyword-maybe-regexp-format org-todo-regexp) - org-complex-heading-regexp - (concat "^\\(\\*+\\)" - "\\(?: +" org-todo-regexp "\\)?" - "\\(?: +\\(\\[#.\\]\\)\\)?" - "\\(?: +\\(.*?\\)\\)??" - (org-re "\\(?:[ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)?") - "[ \t]*$") - org-complex-heading-regexp-format - (concat "^\\(\\*+\\)" - "\\(?: +" org-todo-regexp "\\)?" - "\\(?: +\\(\\[#.\\]\\)\\)?" - "\\(?: +" - ;; Stats cookies can be stuck to body. - "\\(?:\\[[0-9%%/]+\\] *\\)*" - "\\(%s\\)" - "\\(?: *\\[[0-9%%/]+\\]\\)*" - "\\)" - (org-re "\\(?:[ \t]+\\(:[[:alnum:]_@#%%:]+:\\)\\)?") - "[ \t]*$") - org-todo-line-tags-regexp - (concat "^\\(\\*+\\)" - "\\(?: +" org-todo-regexp "\\)?" - "\\(?: +\\(.*?\\)\\)??" - (org-re "\\(?:[ \t]+\\(:[[:alnum:]:_@#%]+:\\)\\)?") - "[ \t]*$") - org-deadline-regexp (concat "\\<" org-deadline-string) - org-deadline-time-regexp - (concat "\\<" org-deadline-string " *<\\([^>]+\\)>") - org-deadline-time-hour-regexp - (concat "\\<" org-deadline-string - " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9-+:hdwmy \t.]*\\)>") - org-deadline-line-regexp - (concat "\\<\\(" org-deadline-string "\\).*") - org-scheduled-regexp - (concat "\\<" org-scheduled-string) - org-scheduled-time-regexp - (concat "\\<" org-scheduled-string " *<\\([^>]+\\)>") - org-scheduled-time-hour-regexp - (concat "\\<" org-scheduled-string - " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9-+:hdwmy \t.]*\\)>") - org-closed-time-regexp - (concat "\\<" org-closed-string " *\\[\\([^]]+\\)\\]") - org-keyword-time-regexp - (concat "\\<\\(" org-scheduled-string - "\\|" org-deadline-string - "\\|" org-closed-string - "\\|" org-clock-string "\\)" - " *[[<]\\([^]>]+\\)[]>]") - org-keyword-time-not-clock-regexp - (concat "\\<\\(" org-scheduled-string - "\\|" org-deadline-string - "\\|" org-closed-string - "\\)" - " *[[<]\\([^]>]+\\)[]>]") - org-maybe-keyword-time-regexp - (concat "\\(\\<\\(" org-scheduled-string - "\\|" org-deadline-string - "\\|" org-closed-string - "\\|" org-clock-string "\\)\\)?" - " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?[]>]\\|<%%([^\r\n>]*>\\)") - org-all-time-keywords - (mapcar (lambda (w) (substring w 0 -1)) - (list org-scheduled-string org-deadline-string - org-clock-string org-closed-string))) - (setq org-ota nil) - (org-compute-latex-and-related-regexp)))) + org-todo-key-trigger (delq nil (mapcar #'cdr org-todo-key-alist)) + org-todo-key-alist (org-assign-fast-keys org-todo-key-alist)) + ;; Compute the regular expressions and other local variables. + ;; Using `org-outline-regexp-bol' would complicate them much, + ;; because of the fixed white space at the end of that string. + (unless org-done-keywords + (setq org-done-keywords + (and org-todo-keywords-1 (last org-todo-keywords-1)))) + (setq org-not-done-keywords + (org-delete-all org-done-keywords + (copy-sequence org-todo-keywords-1)) + org-todo-regexp (regexp-opt org-todo-keywords-1 t) + org-not-done-regexp (regexp-opt org-not-done-keywords t) + org-not-done-heading-regexp + (format org-heading-keyword-regexp-format org-not-done-regexp) + org-todo-line-regexp + (format org-heading-keyword-maybe-regexp-format org-todo-regexp) + org-complex-heading-regexp + (concat "^\\(\\*+\\)" + "\\(?: +" org-todo-regexp "\\)?" + "\\(?: +\\(\\[#.\\]\\)\\)?" + "\\(?: +\\(.*?\\)\\)??" + "\\(?:[ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)?" + "[ \t]*$") + org-complex-heading-regexp-format + (concat "^\\(\\*+\\)" + "\\(?: +" org-todo-regexp "\\)?" + "\\(?: +\\(\\[#.\\]\\)\\)?" + "\\(?: +" + ;; Stats cookies can be stuck to body. + "\\(?:\\[[0-9%%/]+\\] *\\)*" + "\\(%s\\)" + "\\(?: *\\[[0-9%%/]+\\]\\)*" + "\\)" + "\\(?:[ \t]+\\(:[[:alnum:]_@#%%:]+:\\)\\)?" + "[ \t]*$") + org-todo-line-tags-regexp + (concat "^\\(\\*+\\)" + "\\(?: +" org-todo-regexp "\\)?" + "\\(?: +\\(.*?\\)\\)??" + "\\(?:[ \t]+\\(:[[:alnum:]:_@#%]+:\\)\\)?" + "[ \t]*$")) + (org-compute-latex-and-related-regexp))))) + +(defun org--setup-collect-keywords (regexp &optional files alist) + "Return setup keywords values as an alist. + +REGEXP matches a subset of setup keywords. FILES is a list of +file names already visited. It is used to avoid circular setup +files. ALIST, when non-nil, is the alist computed so far. + +Return value contains the following keys: `archive', `category', +`columns', `constants', `filetags', `link', `priorities', +`property', `scripts', `startup', `tags' and `todo'." + (org-with-wide-buffer + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (re-search-forward regexp nil t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'keyword) + (let ((key (org-element-property :key element)) + (value (org-element-property :value element))) + (cond + ((equal key "ARCHIVE") + (when (org-string-nw-p value) + (push (cons 'archive value) alist))) + ((equal key "CATEGORY") (push (cons 'category value) alist)) + ((equal key "COLUMNS") (push (cons 'columns value) alist)) + ((equal key "CONSTANTS") + (let* ((constants (assq 'constants alist)) + (store (cdr constants))) + (dolist (pair (org-split-string value)) + (when (string-match "^\\([a-zA-Z0][_a-zA-Z0-9]*\\)=\\(.*\\)" + pair) + (let* ((name (match-string 1 pair)) + (value (match-string 2 pair)) + (old (assoc name store))) + (if old (setcdr old value) + (push (cons name value) store))))) + (if constants (setcdr constants store) + (push (cons 'constants store) alist)))) + ((equal key "FILETAGS") + (when (org-string-nw-p value) + (let ((old (assq 'filetags alist)) + (new (apply #'nconc + (mapcar (lambda (x) (org-split-string x ":")) + (org-split-string value))))) + (if old (setcdr old (append new (cdr old))) + (push (cons 'filetags new) alist))))) + ((equal key "LINK") + (when (string-match "\\`\\(\\S-+\\)[ \t]+\\(.+\\)" value) + (let ((links (assq 'link alist)) + (pair (cons (match-string-no-properties 1 value) + (match-string-no-properties 2 value)))) + (if links (push pair (cdr links)) + (push (list 'link pair) alist))))) + ((equal key "OPTIONS") + (when (and (org-string-nw-p value) + (string-match "\\^:\\(t\\|nil\\|{}\\)" value)) + (push (cons 'scripts (read (match-string 1 value))) alist))) + ((equal key "PRIORITIES") + (push (cons 'priorities + (let ((prio (org-split-string value))) + (if (< (length prio) 3) '(?A ?C ?B) + (mapcar #'string-to-char prio)))) + alist)) + ((equal key "PROPERTY") + (when (string-match "\\(\\S-+\\)[ \t]+\\(.*\\)" value) + (let* ((property (assq 'property alist)) + (value (org--update-property-plist + (match-string-no-properties 1 value) + (match-string-no-properties 2 value) + (cdr property)))) + (if property (setcdr property value) + (push (cons 'property value) alist))))) + ((equal key "STARTUP") + (let ((startup (assq 'startup alist))) + (if startup + (setcdr startup + (append (cdr startup) (org-split-string value))) + (push (cons 'startup (org-split-string value)) alist)))) + ((equal key "TAGS") + (let ((tag-cell (assq 'tags alist))) + (if tag-cell + (setcdr tag-cell (concat (cdr tag-cell) "\n" value)) + (push (cons 'tags value) alist)))) + ((member key '("TODO" "SEQ_TODO" "TYP_TODO")) + (let ((todo (assq 'todo alist)) + (value (cons (if (equal key "TYP_TODO") 'type 'sequence) + (org-split-string value)))) + (if todo (push value (cdr todo)) + (push (list 'todo value) alist)))) + ((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))))) + (when (and f (file-readable-p f) (not (member f files))) + (with-temp-buffer + (setq default-directory (file-name-directory f)) + (insert-file-contents f) + (setq alist + ;; Fake Org mode to benefit from cache + ;; without recurring needlessly. + (let ((major-mode 'org-mode)) + (org--setup-collect-keywords + regexp (cons f files) alist))))))))))))))) + alist) + +(defun org-tag-string-to-alist (s) + "Return tag alist associated to string S. +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 + "\\(?:(\\(.\\))\\)?\\'")) + alist group-flag) + (dolist (tokens lines (cdr (nreverse alist))) + (push '(:newline) alist) + (while tokens + (let ((token (pop tokens))) + (pcase token + ("{" + (push '(:startgroup) alist) + (when (equal (nth 1 tokens) ":") (setq group-flag t))) + ("}" + (push '(:endgroup) alist) + (setq group-flag nil)) + ("[" + (push '(:startgrouptag) alist) + (when (equal (nth 1 tokens) ":") (setq group-flag t))) + ("]" + (push '(:endgrouptag) alist) + (setq group-flag nil)) + (":" + (push '(:grouptags) alist)) + ((guard (string-match tag-re token)) + (let ((tag (match-string 1 token)) + (key (and (match-beginning 2) + (string-to-char (match-string 2 token))))) + ;; Push all tags in groups, no matter if they already + ;; appear somewhere else in the list. + (when (or group-flag (not (assoc tag alist))) + (push (cons tag key) alist)))))))))) + +(defun org-tag-alist-to-string (alist &optional skip-key) + "Return tag string associated to ALIST. + +ALIST is an alist, as defined in `org-tag-alist' or +`org-tag-persistent-alist', or produced with +`org-tag-string-to-alist'. + +Return value is a string suitable as a value for \"TAGS\" +keyword. + +When optional argument SKIP-KEY is non-nil, skip selection keys +next to tags." + (mapconcat (lambda (token) + (pcase token + (`(:startgroup) "{") + (`(:endgroup) "}") + (`(:startgrouptag) "[") + (`(:endgrouptag) "]") + (`(:grouptags) ":") + (`(:newline) "\\n") + ((and + (guard (not skip-key)) + `(,(and tag (pred stringp)) . ,(and key (pred characterp)))) + (format "%s(%c)" tag key)) + (`(,(and tag (pred stringp)) . ,_) tag) + (_ (user-error "Invalid tag token: %S" token)))) + alist + " ")) + +(defun org-tag-alist-to-groups (alist) + "Return group alist from tag ALIST. +ALIST is an alist, as defined in `org-tag-alist' or +`org-tag-persistent-alist', or produced with +`org-tag-string-to-alist'. Return value is an alist following +the pattern (GROUP-TAG TAGS) where GROUP-TAG is the tag, as +a string, summarizing TAGS, as a list of strings." + (let (groups group-status current-group) + (dolist (token alist (nreverse groups)) + (pcase token + (`(,(or :startgroup :startgrouptag)) (setq group-status t)) + (`(,(or :endgroup :endgrouptag)) + (when (eq group-status 'append) + (push (nreverse current-group) groups)) + (setq group-status nil)) + (`(:grouptags) (setq group-status 'append)) + ((and `(,tag . ,_) (guard group-status)) + (if (eq group-status 'append) (push tag current-group) + (setq current-group (list tag)))) + (_ nil))))) (defun org-file-contents (file &optional noerror) "Return the contents of FILE, as a string." - (if (or (not file) (not (file-readable-p file))) - (if (not noerror) - (error "Cannot read file \"%s\"" file) - (message "Cannot read file \"%s\"" file) - "") - (with-temp-buffer - (insert-file-contents file) - (buffer-string)))) + (if (and file (file-readable-p file)) + (with-temp-buffer + (insert-file-contents file) + (buffer-string)) + (funcall (if noerror 'message 'error) + "Cannot read file \"%s\"%s" + file + (let ((from (buffer-file-name (buffer-base-buffer)))) + (if from (concat " (referenced in file \"" from "\")") ""))))) (defun org-extract-log-state-settings (x) "Extract the log state setting from a TODO keyword string. This will extract info from a string like \"WAIT(w@/!)\"." - (let (kw key log1 log2) - (when (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?\\([!@]\\)?\\(?:/\\([!@]\\)\\)?)\\)?$" x) - (setq kw (match-string 1 x) - key (and (match-end 2) (match-string 2 x)) - log1 (and (match-end 3) (match-string 3 x)) - log2 (and (match-end 4) (match-string 4 x))) + (when (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?\\([!@]\\)?\\(?:/\\([!@]\\)\\)?)\\)?$" x) + (let ((kw (match-string 1 x)) + (log1 (and (match-end 3) (match-string 3 x))) + (log2 (and (match-end 4) (match-string 4 x)))) (and (or log1 log2) (list kw (and log1 (if (equal log1 "!") 'time 'note)) @@ -5216,8 +5469,8 @@ This will extract info from a string like \"WAIT(w@/!)\"." (defun org-assign-fast-keys (alist) "Assign fast keys to a keyword-key alist. Respect keys that are already there." - (let (new (alt ?0)) - (dolist (e alist) + (let (new e (alt ?0)) + (while (setq e (pop alist)) (if (or (memq (car e) '(:newline :grouptags :endgroup :startgroup)) (cdr e)) ;; Key already assigned. (push e new) @@ -5229,7 +5482,7 @@ Respect keys that are already there." (pop clist)) (unless clist (while (rassoc alt used) - (incf alt))) + (cl-incf alt))) (push (cons (car e) (or (car clist) alt)) new)))) (nreverse new))) @@ -5242,13 +5495,7 @@ Respect keys that are already there." (defvar org-finish-function nil "Function to be called when `C-c C-c' is used. This is for getting out of special buffers like capture.") - - -;; FIXME: Occasionally check by commenting these, to make sure -;; no other functions uses these, forgetting to let-bind them. -(org-no-warnings (defvar entry)) ;; unprefixed, from calendar.el (defvar org-last-state) -(org-no-warnings (defvar date)) ;; unprefixed, from calendar.el ;; Defined somewhere in this file, but used before definition. (defvar org-entities) ;; defined in org-entities.el @@ -5256,7 +5503,7 @@ This is for getting out of special buffers like capture.") (defvar org-org-menu) (defvar org-tbl-menu) -;;;; Define the Org-mode +;;;; Define the Org mode ;; We use a before-change function to check if a table might need ;; an update. @@ -5264,7 +5511,7 @@ This is for getting out of special buffers like capture.") "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) +(defun org-before-change-function (_beg _end) "Every change indicates that a table might need an update." (setq org-table-may-need-update t)) (defvar org-mode-map) @@ -5278,13 +5525,12 @@ This variable is set by `org-before-change-function'. (defvar buffer-face-mode-face) (require 'outline) -(if (and (not (keymapp outline-mode-map)) (featurep 'allout)) - (error "Conflict with outdated version of allout.el. Load org.el before allout.el, or upgrade to newer allout, for example by switching to Emacs 22")) -(require 'noutline "noutline" 'noerror) ;; stock XEmacs does not have it ;; Other stuff we need. (require 'time-date) +(unless (fboundp 'time-subtract) (defalias 'time-subtract 'subtract-time)) (require 'easymenu) +(autoload 'easy-menu-add "easymenu") (require 'overlay) ;; (require 'org-macs) moved higher up in the file before it is first used @@ -5305,15 +5551,15 @@ This variable is set by `org-before-change-function'. "Outline-based notes management and organizer, alias \"Carsten's outline-mode for keeping track of everything.\" -Org-mode develops organizational tasks around a NOTES file which -contains information about projects as plain text. Org-mode is -implemented on top of outline-mode, which is ideal to keep the content +Org mode develops organizational tasks around a NOTES file which +contains information about projects as plain text. Org mode is +implemented on top of Outline mode, which is ideal to keep the content of large files well structured. It supports ToDo items, deadlines and time stamps, which magically appear in the diary listing of the Emacs calendar. Tables are easily created with a built-in table editor. Plain text URL-like links connect to websites, emails (VM), Usenet messages (Gnus), BBDB entries, and any files related to the project. -For printing and sharing of notes, an Org-mode file (or a part of it) +For printing and sharing of notes, an Org file (or a part of it) can be exported as a structured ASCII or HTML file. The following commands are available: @@ -5323,29 +5569,18 @@ The following commands are available: ;; 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. - (if (featurep 'xemacs) - (when (boundp 'outline-mode-menu-heading) - ;; Assume this is Greg's port, it uses easymenu - (easy-menu-remove outline-mode-menu-heading) - (easy-menu-remove outline-mode-menu-show) - (easy-menu-remove outline-mode-menu-hide)) - (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)) + ;; 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) - (when (featurep 'xemacs) - (easy-menu-add org-org-menu) - (easy-menu-add org-tbl-menu)) (org-install-agenda-files-menu) - (if org-descriptive-links (add-to-invisibility-spec '(org-link))) + (when org-descriptive-links (add-to-invisibility-spec '(org-link))) (add-to-invisibility-spec '(org-cwidth)) (add-to-invisibility-spec '(org-hide-block . t)) - (when (featurep 'xemacs) - (org-set-local 'line-move-ignore-invisible t)) - (org-set-local 'outline-regexp org-outline-regexp) - (org-set-local 'outline-level 'org-outline-level) + (setq-local outline-regexp org-outline-regexp) + (setq-local outline-level 'org-outline-level) (setq bidi-paragraph-direction 'left-to-right) (when (and org-ellipsis (fboundp 'set-display-table-slot) (boundp 'buffer-display-table) @@ -5354,55 +5589,50 @@ The following commands are available: (setq org-display-table (make-display-table))) (set-display-table-slot org-display-table 4 - (vconcat (mapcar - (lambda (c) (make-glyph-code c (and (not (stringp org-ellipsis)) - org-ellipsis))) - (if (stringp org-ellipsis) org-ellipsis "...")))) + (vconcat (mapcar (lambda (c) (make-glyph-code c 'org-ellipsis)) + (if (stringp org-ellipsis) org-ellipsis "...")))) (setq buffer-display-table org-display-table)) - (org-set-regexps-and-options-for-tags) (org-set-regexps-and-options) (org-set-font-lock-defaults) (when (and org-tag-faces (not org-tags-special-faces-re)) ;; tag faces set outside customize.... force initialization. (org-set-tag-faces 'org-tag-faces org-tag-faces)) ;; Calc embedded - (org-set-local 'calc-embedded-open-mode "# ") + (setq-local calc-embedded-open-mode "# ") ;; Modify a few syntax entries (modify-syntax-entry ?@ "w") (modify-syntax-entry ?\" "\"") (modify-syntax-entry ?\\ "_") (modify-syntax-entry ?~ "_") - (if org-startup-truncated (setq truncate-lines t)) - (when org-startup-indented (require 'org-indent) (org-indent-mode 1)) - (org-set-local 'font-lock-unfontify-region-function - 'org-unfontify-region) + (setq-local font-lock-unfontify-region-function 'org-unfontify-region) ;; Activate before-change-function - (org-set-local 'org-table-may-need-update t) - (org-add-hook 'before-change-functions 'org-before-change-function nil - 'local) + (setq-local org-table-may-need-update t) + (add-hook 'before-change-functions 'org-before-change-function nil 'local) ;; Check for running clock before killing a buffer - (org-add-hook 'kill-buffer-hook 'org-check-running-clock nil 'local) + (add-hook 'kill-buffer-hook 'org-check-running-clock nil 'local) ;; Initialize macros templates. (org-macro-initialize-templates) ;; Initialize radio targets. (org-update-radio-target-regexp) ;; Indentation. - (org-set-local 'indent-line-function 'org-indent-line) - (org-set-local 'indent-region-function 'org-indent-region) + (setq-local indent-line-function 'org-indent-line) + (setq-local indent-region-function 'org-indent-region) ;; Filling and auto-filling. (org-setup-filling) ;; Comments. (org-setup-comments-handling) + ;; Initialize cache. + (org-element-cache-reset) ;; Beginning/end of defun - (org-set-local 'beginning-of-defun-function 'org-backward-element) - (org-set-local 'end-of-defun-function - (lambda () - (if (not (org-at-heading-p)) - (org-forward-element) - (org-forward-element) - (forward-char -1)))) + (setq-local beginning-of-defun-function 'org-backward-element) + (setq-local end-of-defun-function + (lambda () + (if (not (org-at-heading-p)) + (org-forward-element) + (org-forward-element) + (forward-char -1)))) ;; Next error for sparse trees - (org-set-local 'next-error-function 'org-occur-next-match) + (setq-local next-error-function 'org-occur-next-match) ;; Make sure dependence stuff works reliably, even for users who set it ;; too late :-( (if org-enforce-todo-dependencies @@ -5417,78 +5647,65 @@ The following commands are available: 'org-block-todo-from-checkboxes)) ;; Align options lines - (org-set-local - 'align-mode-rules-list + (setq-local + align-mode-rules-list '((org-in-buffer-settings - (regexp . "^#\\+[A-Z_]+:\\(\\s-*\\)\\S-+") + (regexp . "^[ \t]*#\\+[A-Z_]+:\\(\\s-*\\)\\S-+") (modes . '(org-mode))))) ;; Imenu - (org-set-local 'imenu-create-index-function - 'org-imenu-get-tree) + (setq-local imenu-create-index-function 'org-imenu-get-tree) ;; Make isearch reveal context - (if (or (featurep 'xemacs) - (not (boundp 'outline-isearch-open-invisible-function))) - ;; Emacs 21 and XEmacs make use of the hook - (org-add-hook 'isearch-mode-end-hook 'org-isearch-end 'append 'local) - ;; Emacs 22 deals with this through a special variable - (org-set-local 'outline-isearch-open-invisible-function - (lambda (&rest ignore) (org-show-context 'isearch)))) + (setq-local outline-isearch-open-invisible-function + (lambda (&rest _) (org-show-context 'isearch))) ;; Setup the pcomplete hooks - (set (make-local-variable 'pcomplete-command-completion-function) - 'org-pcomplete-initial) - (set (make-local-variable 'pcomplete-command-name-function) - 'org-command-at-point) - (set (make-local-variable 'pcomplete-default-completion-function) - 'ignore) - (set (make-local-variable 'pcomplete-parse-arguments-function) - 'org-parse-arguments) - (set (make-local-variable 'pcomplete-termination-string) "") - (when (>= emacs-major-version 23) - (set (make-local-variable 'buffer-face-mode-face) 'org-default)) - - ;; If empty file that did not turn on org-mode automatically, make it to. - (if (and org-insert-mode-line-in-empty-file - (org-called-interactively-p 'any) - (= (point-min) (point-max))) - (insert "# -*- mode: org -*-\n\n")) + (setq-local pcomplete-command-completion-function 'org-pcomplete-initial) + (setq-local pcomplete-command-name-function 'org-command-at-point) + (setq-local pcomplete-default-completion-function 'ignore) + (setq-local pcomplete-parse-arguments-function 'org-parse-arguments) + (setq-local pcomplete-termination-string "") + (setq-local buffer-face-mode-face 'org-default) + + ;; If empty file that did not turn on Org mode automatically, make + ;; it to. + (when (and org-insert-mode-line-in-empty-file + (called-interactively-p 'any) + (= (point-min) (point-max))) + (insert "# -*- mode: org -*-\n\n")) (unless org-inhibit-startup (org-unmodified - (and org-startup-with-beamer-mode (org-beamer-mode)) + (when org-startup-with-beamer-mode (org-beamer-mode)) (when org-startup-align-all-tables - (org-table-map-tables 'org-table-align 'quietly)) - (when org-startup-with-inline-images - (org-display-inline-images)) - (when org-startup-with-latex-preview - (org-preview-latex-fragment)) - (unless org-inhibit-startup-visibility-stuff - (org-set-startup-visibility)))) - ;; Try to set org-hide correctly + (org-table-map-tables #'org-table-align t)) + (when org-startup-with-inline-images (org-display-inline-images)) + (when org-startup-with-latex-preview (org-toggle-latex-fragment '(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))) + ;; Try to set `org-hide' face correctly. (let ((foreground (org-find-invisible-foreground))) - (if foreground - (set-face-foreground 'org-hide foreground)))) + (when foreground + (set-face-foreground 'org-hide foreground)))) ;; Update `customize-package-emacs-version-alist' (add-to-list 'customize-package-emacs-version-alist '(Org ("6.21b" . "23.1") ("6.33x" . "23.2") ("7.8.11" . "24.1") ("7.9.4" . "24.3") - ("8.2.6" . "24.4"))) + ("8.2.6" . "24.4") ("8.2.10" . "24.5") + ("9.0" . "26.1"))) (defvar org-mode-transpose-word-syntax-table - (let ((st (make-syntax-table))) - (mapc (lambda(c) (modify-syntax-entry - (string-to-char (car c)) "w p" st)) - org-emphasis-alist) - st)) + (let ((st (make-syntax-table text-mode-syntax-table))) + (dolist (c org-emphasis-alist st) + (modify-syntax-entry (string-to-char (car c)) "w p" st)))) (when (fboundp 'abbrev-table-put) (abbrev-table-put org-mode-abbrev-table :parents (list text-mode-abbrev-table))) -(put 'org-mode 'flyspell-mode-predicate 'org-mode-flyspell-verify) - (defun org-find-invisible-foreground () (let ((candidates (remove "unspecified-bg" @@ -5498,7 +5715,7 @@ The following commands are available: (mapcar (lambda (alist) (when (boundp alist) - (cdr (assoc 'background-color (symbol-value alist))))) + (cdr (assq 'background-color (symbol-value alist))))) '(default-frame-alist initial-frame-alist window-system-default-frame-alist)) (list (face-foreground 'org-hide)))))) (car (remove nil candidates)))) @@ -5541,8 +5758,6 @@ the rounding returns a past time." (require 'font-lock) (defconst org-non-link-chars "]\t\n\r<>") -(defvar org-link-types '("http" "https" "ftp" "mailto" "file" "news" - "shell" "elisp" "doi" "message")) (defvar org-link-types-re nil "Matches a link that has a url-like prefix like \"http:\"") (defvar org-link-re-with-space nil @@ -5591,27 +5806,26 @@ stacked delimiters is N. Escaping delimiters is not possible." next (concat "\\(?:" nothing left next right "\\)+" nothing))) (concat left "\\(" re "\\)" right))) -(defvar org-match-substring-regexp +(defconst org-match-substring-regexp (concat "\\(\\S-\\)\\([_^]\\)\\(" - "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)" + "\\(?:" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)" "\\|" - "\\(" (org-create-multibrace-regexp "(" ")" org-match-sexp-depth) "\\)" + "\\(?:" (org-create-multibrace-regexp "(" ")" org-match-sexp-depth) "\\)" "\\|" - "\\(\\(?:\\*\\|[-+]?[^-+*!@#$%^_ \t\r\n,:\"?<>~;./{}=()]+\\)\\)\\)") + "\\(?:\\*\\|[+-]?[[:alnum:].,\\]*[[:alnum:]]\\)\\)") "The regular expression matching a sub- or superscript.") -(defvar org-match-substring-with-braces-regexp +(defconst org-match-substring-with-braces-regexp (concat - "\\(\\S-\\)\\([_^]\\)\\(" - "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)" - "\\)") + "\\(\\S-\\)\\([_^]\\)" + "\\(" (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-types' has changed." - (let ((types-re (regexp-opt org-link-types t))) +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 @@ -5629,14 +5843,12 @@ This should be called after the variable `org-link-types' has changed." "\\([^" org-non-link-chars " ]" "[^\t\n\r]*\\)") org-angle-link-re - (concat "<" types-re ":" - "\\([^" org-non-link-chars " ]" - "[^" org-non-link-chars "]*" - "\\)>") + (format "<%s:\\([^>\n]*\\(?:\n[ \t]*[^> \t\n][^>\n]*\\)*\\)>" + types-re) org-plain-link-re (concat "\\<" types-re ":" - (org-re "\\([^ \t\n()<>]+\\(?:([[:word:]0-9_]+)\\|\\([^[:punct:] \t\n]\\|/\\)\\)\\)")) + "\\([^][ \t\n()<>]+\\(?:([[:word:]0-9_]+)\\|\\([^[:punct:] \t\n]\\|/\\)\\)\\)") ;; "\\([^]\t\n\r<>() ]+[^]\t\n\r<>,.;() ]\\)") org-bracket-link-regexp "\\[\\[\\([^][]+\\)\\]\\(\\[\\([^][]+\\)\\]\\)?\\]" @@ -5651,7 +5863,7 @@ This should be called after the variable `org-link-types' has changed." org-bracket-link-analytic-regexp++ (concat "\\[\\[" - "\\(" (regexp-opt (cons "coderef" org-link-types) t) ":\\)?" + "\\(" (regexp-opt (cons "coderef" (org-link-types)) t) ":\\)?" "\\([^]]+\\)" "\\]" "\\(\\[" "\\([^]]+\\)" "\\]\\)?" @@ -5663,65 +5875,34 @@ This should be called after the variable `org-link-types' has changed." (org-make-link-regexps) -(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)>" - "Regular expression for fast time stamp matching.") -(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?\\)[]>]" - "Regular expression for fast time stamp matching.") -(defconst org-ts-regexp0 - "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\)\\( +[^]+0-9>\r\n -]+\\)?\\( +\\([0-9]\\{1,2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)" - "Regular expression matching time strings for analysis. -This one does not require the space after the date, so it can be used -on a string that terminates immediately after the date.") -(defconst org-ts-regexp1 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\) *\\([^]+0-9>\r\n -]*\\)\\( \\([0-9]\\{1,2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)" - "Regular expression matching time strings for analysis.") -(defconst org-ts-regexp2 (concat "<" org-ts-regexp1 "[^>\n]\\{0,16\\}>") - "Regular expression matching time stamps, with groups.") -(defconst org-ts-regexp3 (concat "[[<]" org-ts-regexp1 "[^]>\n]\\{0,16\\}[]>]") - "Regular expression matching time stamps (also [..]), with groups.") -(defconst org-tr-regexp (concat org-ts-regexp "--?-?" org-ts-regexp) - "Regular expression matching a time stamp range.") -(defconst org-tr-regexp-both - (concat org-ts-regexp-both "--?-?" org-ts-regexp-both) - "Regular expression matching a time stamp range.") -(defconst org-tsr-regexp (concat org-ts-regexp "\\(--?-?" - org-ts-regexp "\\)?") - "Regular expression matching a time stamp or time stamp range.") -(defconst org-tsr-regexp-both - (concat org-ts-regexp-both "\\(--?-?" - org-ts-regexp-both "\\)?") - "Regular expression matching a time stamp or time stamp range. -The time stamps may be either active or inactive.") - (defvar org-emph-face nil) (defun org-do-emphasis-faces (limit) - "Run through the buffer and add overlays to emphasized strings." + "Run through the buffer and emphasize strings." (let (rtn a) (while (and (not rtn) (re-search-forward org-emph-re limit t)) (let* ((border (char-after (match-beginning 3))) (bre (regexp-quote (char-to-string border)))) - (if (and (not (= border (char-after (match-beginning 4)))) - (not (save-match-data - (string-match (concat bre ".*" bre) - (replace-regexp-in-string - "\n" " " - (substring (match-string 2) 1 -1)))))) - (progn - (setq rtn t) - (setq a (assoc (match-string 3) org-emphasis-alist)) - (font-lock-prepend-text-property (match-beginning 2) (match-end 2) - 'face - (nth 1 a)) - (and (nth 2 a) - (org-remove-flyspell-overlays-in - (match-beginning 0) (match-end 0))) - (add-text-properties (match-beginning 2) (match-end 2) - '(font-lock-multiline t org-emphasis t)) - (when org-hide-emphasis-markers - (add-text-properties (match-end 4) (match-beginning 5) - '(invisible org-link)) - (add-text-properties (match-beginning 3) (match-end 3) - '(invisible org-link)))))) + (when (and (not (= border (char-after (match-beginning 4)))) + (not (string-match-p (concat bre ".*" bre) + (replace-regexp-in-string + "\n" " " + (substring (match-string 2) 1 -1))))) + (setq rtn t) + (setq a (assoc (match-string 3) org-emphasis-alist)) + (font-lock-prepend-text-property (match-beginning 2) (match-end 2) + 'face + (nth 1 a)) + (and (nth 2 a) + (org-remove-flyspell-overlays-in + (match-beginning 0) (match-end 0))) + (add-text-properties (match-beginning 2) (match-end 2) + '(font-lock-multiline t org-emphasis t)) + (when org-hide-emphasis-markers + (add-text-properties (match-end 4) (match-beginning 5) + '(invisible org-link)) + (add-text-properties (match-beginning 3) (match-end 3) + '(invisible org-link))))) (goto-char (1+ (match-beginning 0)))) rtn)) @@ -5736,19 +5917,20 @@ If CHAR is not given (for example in an interactive call) it will be prompted for." (interactive) (let ((erc org-emphasis-regexp-components) - (prompt "") - (string "") beg end move c s) + (string "") beg end move s) (if (org-region-active-p) - (setq beg (region-beginning) end (region-end) + (setq beg (region-beginning) + end (region-end) string (buffer-substring beg end)) (setq move t)) (unless char (message "Emphasis marker or tag: [%s]" - (mapconcat (lambda(e) (car e)) org-emphasis-alist "")) + (mapconcat #'car org-emphasis-alist "")) (setq char (read-char-exclusive))) - (if (equal char ?\ ) - (setq s "" move nil) + (if (equal char ?\s) + (setq s "" + move nil) (unless (assoc (char-to-string char) org-emphasis-alist) (user-error "No such emphasis marker: \"%c\"" char)) (setq s (char-to-string char))) @@ -5757,7 +5939,7 @@ prompted for." (assoc (substring string 0 1) org-emphasis-alist)) (setq string (substring string 1 -1))) (setq string (concat s string s)) - (if beg (delete-region beg end)) + (when beg (delete-region beg end)) (unless (or (bolp) (string-match (concat "[" (nth 0 erc) "\n]") (char-to-string (char-before (point))))) @@ -5775,37 +5957,86 @@ prompted for." (defsubst org-rear-nonsticky-at (pos) (add-text-properties (1- pos) pos (list 'rear-nonsticky org-nonsticky-props))) -(defun org-activate-plain-links (limit) - "Run through the buffer and add overlays to links." - (let (f hl) - (when (and (re-search-forward (concat org-plain-link-re) limit t) - (not (org-in-src-block-p))) - (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) - (setq f (get-text-property (match-beginning 0) 'face)) - (setq hl (org-match-string-no-properties 0)) - (if (or (eq f 'org-tag) - (and (listp f) (memq 'org-tag f))) - nil - (add-text-properties (match-beginning 0) (match-end 0) - (list 'mouse-face 'highlight - 'face 'org-link - 'htmlize-link `(:uri ,hl) - 'keymap org-mouse-map)) - (org-rear-nonsticky-at (match-end 0))) - t))) +(defun org-activate-links (limit) + "Add link properties to links. +This includes angle, plain, and bracket links." + (catch :exit + (while (re-search-forward org-any-link-re limit t) + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (style (cond ((eq ?< (char-after start)) 'angle) + ((eq ?\[ (char-after (1+ start))) 'bracket) + (t 'plain)))) + (when (and (memq style org-highlight-links) + ;; Do not confuse plain links with tags. + (not (and (eq style 'plain) + (let ((face (get-text-property + (max (1- start) (point-min)) 'face))) + (if (consp face) (memq 'org-tag face) + (eq 'org-tag face)))))) + (let* ((link-object (save-excursion + (goto-char start) + (save-match-data (org-element-link-parser)))) + (link (org-element-property :raw-link link-object)) + (type (org-element-property :type link-object)) + (path (org-element-property :path link-object)) + (properties ;for link's visible part + (list + 'face (pcase (org-link-get-parameter type :face) + ((and (pred functionp) face) (funcall face path)) + ((and (pred facep) face) face) + ((and (pred consp) face) face) ;anonymous + (_ 'org-link)) + 'mouse-face (or (org-link-get-parameter type :mouse-face) + 'highlight) + 'keymap (or (org-link-get-parameter type :keymap) + org-mouse-map) + 'help-echo (pcase (org-link-get-parameter type :help-echo) + ((and (pred stringp) echo) echo) + ((and (pred functionp) echo) echo) + (_ (concat "LINK: " link))) + 'htmlize-link (pcase (org-link-get-parameter type + :htmlize-link) + ((and (pred functionp) f) (funcall f)) + (_ `(:uri ,link))) + 'font-lock-multiline t))) + (org-remove-flyspell-overlays-in start end) + (org-rear-nonsticky-at end) + (if (not (eq 'bracket style)) + (add-text-properties start end properties) + ;; Handle invisible parts in bracket links. + (remove-text-properties start end '(invisible nil)) + (let ((hidden + (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)))) + (add-text-properties start visible-start hidden) + (add-text-properties visible-start visible-end properties) + (add-text-properties visible-end end hidden) + (org-rear-nonsticky-at visible-start) + (org-rear-nonsticky-at visible-end))) + (let ((f (org-link-get-parameter type :activate-func))) + (when (functionp f) + (funcall f start end path (eq style 'bracket)))) + (throw :exit t))))) ;signal success + nil)) (defun org-activate-code (limit) - (if (re-search-forward "^[ \t]*\\(:\\(?: .*\\|$\\)\n?\\)" limit t) - (progn - (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) - (remove-text-properties (match-beginning 0) (match-end 0) - '(display t invisible t intangible t)) - t))) + (when (re-search-forward "^[ \t]*\\(:\\(?: .*\\|$\\)\n?\\)" limit t) + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (remove-text-properties (match-beginning 0) (match-end 0) + '(display t invisible t intangible t)) + t)) -(defcustom org-src-fontify-natively nil - "When non-nil, fontify code in code blocks." +(defcustom org-src-fontify-natively t + "When non-nil, fontify code in code blocks. +See also the `org-block' face." :type 'boolean - :version "24.1" + :version "24.4" + :package-version '(Org . "8.3") :group 'org-appearance :group 'org-babel) @@ -5820,221 +6051,248 @@ by a #." (defun org-fontify-meta-lines-and-blocks (limit) (condition-case nil (org-fontify-meta-lines-and-blocks-1 limit) - (error (message "org-mode fontification error")))) + (error (message "org-mode fontification error in %S at %d" + (current-buffer) + (line-number-at-pos))))) (defun org-fontify-meta-lines-and-blocks-1 (limit) "Fontify #+ lines and blocks." (let ((case-fold-search t)) - (if (re-search-forward - "^\\([ \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)) - (dc1 (downcase (match-string 2))) - (dc3 (downcase (match-string 3))) - end end1 quoting block-type ovl) - (cond - ((member dc1 '("+html:" "+ascii:" "+latex:")) - ;; a single line of backend-specific content - (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) - (remove-text-properties (match-beginning 0) (match-end 0) - '(display t invisible t intangible t)) - (add-text-properties (match-beginning 1) (match-end 3) - '(font-lock-fontified t face org-meta-line)) - (add-text-properties (match-beginning 6) (+ (match-end 6) 1) - '(font-lock-fontified t face org-block)) - ; for backend-specific code - t) - ((and (match-end 4) (equal dc3 "+begin")) - ;; Truly a block - (setq block-type (downcase (match-string 5)) - quoting (member block-type org-protecting-blocks)) - (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)) - (when quoting - (remove-text-properties beg end - '(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)) - (add-text-properties end1 (min (point-max) (1+ end)) - '(face org-meta-line)) ; for end_src - (cond - ((and lang (not (string= lang "")) org-src-fontify-natively) - (org-src-font-lock-fontify-block lang block-start block-end) - ;; remove old background overlays - (mapc (lambda (ov) - (if (eq (overlay-get ov 'face) 'org-block-background) - (delete-overlay ov))) - (overlays-at (/ (+ beg1 block-end) 2))) - ;; add a background overlay - (setq ovl (make-overlay beg1 block-end)) - (overlay-put ovl 'face 'org-block-background) - (overlay-put ovl 'evaporate t)) ;; make it go away when empty - (quoting - (add-text-properties beg1 (min (point-max) (1+ end1)) - '(face org-block))) ; end of source block - ((not org-fontify-quote-and-verse-blocks)) - ((string= block-type "quote") - (add-text-properties beg1 (min (point-max) (1+ end1)) '(face org-quote))) - ((string= block-type "verse") - (add-text-properties beg1 (min (point-max) (1+ end1)) '(face org-verse)))) - (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)) - t)) - ((member dc1 '("+title:" "+author:" "+email:" "+date:")) - (add-text-properties - beg (match-end 3) - (if (member (intern (substring dc1 1 -1)) org-hidden-keywords) - '(font-lock-fontified t invisible t) - '(font-lock-fontified t face org-document-info-keyword))) - (add-text-properties - (match-beginning 6) (min (point-max) (1+ (match-end 6))) - (if (string-equal dc1 "+title:") - '(font-lock-fontified t face org-document-title) - '(font-lock-fontified t face org-document-info)))) - ((or (equal dc1 "+results") - (member dc1 '("+begin:" "+end:" "+caption:" "+label:" - "+orgtbl:" "+tblfm:" "+tblname:" "+results:" - "+call:" "+header:" "+headers:" "+name:")) - (and (match-end 4) (equal dc3 "+attr"))) - (add-text-properties - beg (match-end 0) - '(font-lock-fontified t face org-meta-line)) - t) - ((member dc3 '(" " "")) - (add-text-properties - beg (match-end 0) - '(font-lock-fontified t face font-lock-comment-face))) - ((not (member (char-after beg) '(?\ ?\t))) - ;; just any other in-buffer setting, but not indented + (when (re-search-forward + "^\\([ \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)) + (dc1 (downcase (match-string 2))) + (dc3 (downcase (match-string 3))) + end end1 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)) + (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)) + (when quoting + (org-remove-flyspell-overlays-in beg1 end1) + (remove-text-properties beg end + '(display t invisible t intangible t))) (add-text-properties - beg (match-end 0) - '(font-lock-fontified t face org-meta-line)) - t) - (t nil)))))) - -(defun org-activate-angle-links (limit) - "Run through the buffer and add overlays to links." - (if (and (re-search-forward org-angle-link-re limit t) - (not (org-in-src-block-p))) - (progn - (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) - (add-text-properties (match-beginning 0) (match-end 0) - (list 'mouse-face 'highlight - 'keymap org-mouse-map)) - (org-rear-nonsticky-at (match-end 0)) - t))) + 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) + (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))) + (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 + ((not org-fontify-quote-and-verse-blocks)) + ((string= block-type "quote") + (add-face-text-property + beg1 (min (point-max) (1+ end1)) '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)) + t)) + ((member dc1 '("+title:" "+author:" "+email:" "+date:")) + (org-remove-flyspell-overlays-in + (match-beginning 0) + (if (equal "+title:" dc1) (match-end 2) (match-end 0))) + (add-text-properties + beg (match-end 3) + (if (member (intern (substring dc1 1 -1)) org-hidden-keywords) + '(font-lock-fontified t invisible t) + '(font-lock-fontified t face org-document-info-keyword))) + (add-text-properties + (match-beginning 6) (min (point-max) (1+ (match-end 6))) + (if (string-equal dc1 "+title:") + '(font-lock-fontified t face org-document-title) + '(font-lock-fontified t face org-document-info)))) + ((string-prefix-p "+caption" dc1) + (org-remove-flyspell-overlays-in (match-end 2) (match-end 0)) + (remove-text-properties (match-beginning 0) (match-end 0) + '(display t invisible t intangible t)) + ;; Handle short captions. + (save-excursion + (beginning-of-line) + (looking-at "\\([ \t]*#\\+caption\\(?:\\[.*\\]\\)?:\\)[ \t]*")) + (add-text-properties (line-beginning-position) (match-end 1) + '(font-lock-fontified t face org-meta-line)) + (add-text-properties (match-end 0) (line-end-position) + '(font-lock-fontified t face org-block)) + t) + ((member dc3 '(" " "")) + (org-remove-flyspell-overlays-in beg (match-end 0)) + (add-text-properties + beg (match-end 0) + '(font-lock-fontified t face font-lock-comment-face))) + (t ;; just any other in-buffer setting, but not indented + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (remove-text-properties (match-beginning 0) (match-end 0) + '(display t invisible t intangible t)) + (add-text-properties beg (match-end 0) + '(font-lock-fontified t face org-meta-line)) + t)))))) + +(defun org-fontify-drawers (limit) + "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)) + t)) + +(defun org-fontify-macros (limit) + "Fontify macros." + (when (re-search-forward "\\({{{\\).+?\\(}}}\\)" limit t) + (add-text-properties + (match-beginning 0) (match-end 0) + '(font-lock-fontified t face org-macro)) + (when org-hide-macro-markers + (add-text-properties (match-end 2) (match-beginning 2) + '(invisible t)) + (add-text-properties (match-beginning 1) (match-end 1) + '(invisible t))) + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + t)) (defun org-activate-footnote-links (limit) - "Run through the buffer and add overlays to footnotes." + "Add text properties for footnotes." (let ((fn (org-footnote-next-reference-or-definition limit))) (when fn - (let ((beg (nth 1 fn)) (end (nth 2 fn))) - (org-remove-flyspell-overlays-in beg end) + (let* ((beg (nth 1 fn)) + (end (nth 2 fn)) + (label (car fn)) + (referencep (/= (line-beginning-position) beg))) + (when (and referencep (nth 3 fn)) + (save-excursion + (goto-char beg) + (search-forward (or label "fn:")) + (org-remove-flyspell-overlays-in beg (match-end 0)))) (add-text-properties beg end (list 'mouse-face 'highlight 'keymap org-mouse-map 'help-echo - (if (= (point-at-bol) beg) - "Footnote definition" - "Footnote reference") + (if referencep "Footnote reference" + "Footnote definition") 'font-lock-fontified t 'font-lock-multiline t 'face 'org-footnote)))))) -(defun org-activate-bracket-links (limit) - "Run through the buffer and add overlays to bracketed links." - (if (and (re-search-forward org-bracket-link-regexp limit t) - (not (org-in-src-block-p))) - (let* ((hl (org-match-string-no-properties 1)) - (help (concat "LINK: " (save-match-data (org-link-unescape hl)))) - (ip (org-maybe-intangible - (list 'invisible 'org-link - 'keymap org-mouse-map 'mouse-face 'highlight - 'font-lock-multiline t 'help-echo help - 'htmlize-link `(:uri ,hl)))) - (vp (list 'keymap org-mouse-map 'mouse-face 'highlight - 'font-lock-multiline t 'help-echo help - 'htmlize-link `(:uri ,hl)))) - ;; We need to remove the invisible property here. Table narrowing - ;; may have made some of this invisible. - (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) - (remove-text-properties (match-beginning 0) (match-end 0) - '(invisible nil)) - (if (match-end 3) - (progn - (add-text-properties (match-beginning 0) (match-beginning 3) ip) - (org-rear-nonsticky-at (match-beginning 3)) - (add-text-properties (match-beginning 3) (match-end 3) vp) - (org-rear-nonsticky-at (match-end 3)) - (add-text-properties (match-end 3) (match-end 0) ip) - (org-rear-nonsticky-at (match-end 0))) - (add-text-properties (match-beginning 0) (match-beginning 1) ip) - (org-rear-nonsticky-at (match-beginning 1)) - (add-text-properties (match-beginning 1) (match-end 1) vp) - (org-rear-nonsticky-at (match-end 1)) - (add-text-properties (match-end 1) (match-end 0) ip) - (org-rear-nonsticky-at (match-end 0))) - t))) - (defun org-activate-dates (limit) - "Run through the buffer and add overlays to dates." - (if (and (re-search-forward org-tsr-regexp-both limit t) - (not (equal (char-before (match-beginning 0)) 91))) - (progn - (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) - (add-text-properties (match-beginning 0) (match-end 0) - (list 'mouse-face 'highlight - 'keymap org-mouse-map)) - (org-rear-nonsticky-at (match-end 0)) - (when org-display-custom-times - (if (match-end 3) - (org-display-custom-time (match-beginning 3) (match-end 3))) - (org-display-custom-time (match-beginning 1) (match-end 1))) - t))) - -(defvar org-target-link-regexp nil + "Add text properties for dates." + (when (and (re-search-forward org-tsr-regexp-both limit t) + (not (equal (char-before (match-beginning 0)) 91))) + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'keymap org-mouse-map)) + (org-rear-nonsticky-at (match-end 0)) + (when org-display-custom-times + (if (match-end 3) + (org-display-custom-time (match-beginning 3) (match-end 3)) + (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.") -(make-variable-buffer-local 'org-target-link-regexp) -(defvar org-target-regexp "<<\\([^<>\n\r]+\\)>>" + +(defconst org-target-regexp (let ((border "[^<>\n\r \t]")) + (format "<<\\(%s\\|%s[^<>\n\r]*%s\\)>>" + border border border)) "Regular expression matching a link target.") -(defvar org-radio-target-regexp "<<<\\([^<>\n\r]+\\)>>>" + +(defconst org-radio-target-regexp (format "<%s>" org-target-regexp) "Regular expression matching a radio target.") -(defvar org-any-target-regexp "<<<?\\([^<>\n\r]+\\)>>>?" ; FIXME, not exact, would match <<<aaa>> as 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) - "Run through the buffer and add overlays to target matches." + "Add text properties for target matches." (when org-target-link-regexp (let ((case-fold-search t)) - (if (re-search-forward org-target-link-regexp limit t) - (progn - (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) - (add-text-properties (match-beginning 0) (match-end 0) - (list 'mouse-face 'highlight - 'keymap org-mouse-map - 'help-echo "Radio target link" - 'org-linked-text t)) - (org-rear-nonsticky-at (match-end 0)) - t))))) + (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) + (list 'mouse-face 'highlight + 'keymap org-mouse-map + 'help-echo "Radio target link" + 'org-linked-text t)) + (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." + "Find all radio targets in this file and update the regular expression. +Also refresh fontification if needed." (interactive) - (when (memq 'radio org-activate-links) + (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 - (org-make-target-link-regexp (org-all-targets 'radio))) - (org-restart-font-lock))) + (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) @@ -6042,20 +6300,18 @@ by a #." 'org-cwidth t)) (when s (setq e (next-single-property-change s 'org-cwidth)) - (add-text-properties s e (org-maybe-intangible '(invisible 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.") -(defvar org-match-substring-regexp) -(defvar org-match-substring-with-braces-regexp) (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'." - (org-set-local - 'org-latex-and-related-regexp + (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 '{}) @@ -6081,9 +6337,13 @@ 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 (memq (car-safe (get-text-property (1+ (match-beginning 0)) - 'face)) - '(org-code org-verbatim underline)) + (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 @@ -6102,63 +6362,32 @@ done, nil otherwise." (font-lock-mode -1) (font-lock-mode 1))) -(defun org-all-targets (&optional radio) - "Return a list of all targets in this file. -When optional argument RADIO is non-nil, only find radio -targets." - (let ((re (if radio org-radio-target-regexp org-target-regexp)) rtn) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward re nil t) - ;; Make sure point is really within the object. - (backward-char) - (let ((obj (org-element-context))) - (when (memq (org-element-type obj) '(radio-target target)) - (add-to-list 'rtn (downcase (org-element-property :value obj)))))) - rtn))) - -(defun org-make-target-link-regexp (targets) - "Make regular expression matching all strings in TARGETS. -The regular expression finds the targets also if there is a line break -between words." - (and targets - (concat - "\\_<\\(" - (mapconcat - (lambda (x) - (setq x (regexp-quote x)) - (while (string-match " +" x) - (setq x (replace-match "\\s-+" t t x))) - x) - targets - "\\|") - "\\)\\_>"))) - (defun org-activate-tags (limit) - (if (re-search-forward (org-re "^\\*+.*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \r\n]") limit t) - (progn - (org-remove-flyspell-overlays-in (match-beginning 1) (match-end 1)) - (add-text-properties (match-beginning 1) (match-end 1) - (list 'mouse-face 'highlight - 'keymap org-mouse-map)) - (org-rear-nonsticky-at (match-end 1)) - t))) + (when (re-search-forward + "^\\*+.*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$" 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 + 'keymap org-mouse-map)) + (org-rear-nonsticky-at (match-end 1)) + t)) (defun org-outline-level () "Compute the outline level of the heading at point. -If this is called at a normal headline, the level is the number of stars. -Use `org-reduced-level' to remove the effect of `org-odd-levels'." - (save-excursion - (if (not (condition-case nil - (org-back-to-heading t) - (error nil))) - 0 - (looking-at org-outline-regexp) - (1- (- (match-end 0) (match-beginning 0)))))) + +If this is called at a normal headline, the level is the number +of stars. Use `org-reduced-level' to remove the effect of +`org-odd-levels'. Unlike to `org-current-level', this function +takes into consideration inlinetasks." + (org-with-wide-buffer + (end-of-line) + (if (re-search-backward org-outline-regexp-bol nil t) + (1- (- (match-end 0) (match-beginning 0))) + 0))) (defvar org-font-lock-keywords nil) -(defsubst org-re-property (property &optional literal allow-null) +(defsubst org-re-property (property &optional literal allow-null value) "Return a regexp matching a PROPERTY line. When optional argument LITERAL is non-nil, do not quote PROPERTY. @@ -6166,17 +6395,25 @@ This is useful when PROPERTY is a regexp. When ALLOW-NULL is non-nil, match properties even without a value. Match group 3 is set to the value when it exists. If there is no -value and ALLOW-NULL is non-nil, it is set to the empty string." +value and ALLOW-NULL is non-nil, it is set to the empty string. + +With optional argument VALUE, match only property lines with +that value; in this case, ALLOW-NULL is ignored. VALUE is quoted +unless LITERAL is non-nil." (concat "^\\(?4:[ \t]*\\)" (format "\\(?1::\\(?2:%s\\):\\)" (if literal property (regexp-quote property))) - (if allow-null - "\\(?:\\(?3:$\\)\\|[ \t]+\\(?3:.*?\\)\\)\\(?5:[ \t]*\\)$" - "[ \t]+\\(?3:[^ \r\t\n]+.*?\\)\\(?5:[ \t]*\\)$"))) + (cond (value + (format "[ \t]+\\(?3:%s\\)\\(?5:[ \t]*\\)$" + (if literal value (regexp-quote value)))) + (allow-null + "\\(?:\\(?3:$\\)\\|[ \t]+\\(?3:.*?\\)\\)\\(?5:[ \t]*\\)$") + (t + "[ \t]+\\(?3:[^ \r\t\n]+.*?\\)\\(?5:[ \t]*\\)$")))) (defconst org-property-re - (org-re-property ".*?" 'literal t) + (org-re-property "\\S-+" 'literal t) "Regular expression matching a property line. There are four matching groups: 1: :PROPKEY: including the leading and trailing colon, @@ -6188,6 +6425,8 @@ There are four matching groups: (defvar org-font-lock-hook nil "Functions to be called for special font lock stuff.") +(defvar org-font-lock-extra-keywords nil) ;Dynamically scoped. + (defvar org-font-lock-set-keywords-hook nil "Functions that can manipulate `org-font-lock-extra-keywords'. This is called after `org-font-lock-extra-keywords' is defined, but before @@ -6201,7 +6440,7 @@ needs to be inserted at a specific position in the font-lock sequence.") (defun org-set-font-lock-defaults () "Set font lock defaults for the current buffer." (let* ((em org-fontify-emphasized-text) - (lk org-activate-links) + (lk org-highlight-links) (org-font-lock-extra-keywords (list ;; Call the hook @@ -6222,26 +6461,23 @@ needs to be inserted at a specific position in the font-lock sequence.") '("^[ \t]*|\\( *\\([$!_^/]\\) *|.*\\)|" (1 'org-formula t)) '("| *\\(<[lrc]?[0-9]*>\\)" (1 'org-formula t)) ;; Drawers - (list org-drawer-regexp '(0 'org-special-keyword t)) - (list "^[ \t]*:END:" '(0 'org-special-keyword t)) + '(org-fontify-drawers) ;; Properties (list org-property-re '(1 'org-special-keyword t) '(3 'org-property-value t)) - ;; Links - (if (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend))) - (if (memq 'angle lk) '(org-activate-angle-links (0 'org-link t))) - (if (memq 'plain lk) '(org-activate-plain-links (0 'org-link t))) - (if (memq 'bracket lk) '(org-activate-bracket-links (0 'org-link t))) - (if (memq 'radio lk) '(org-activate-target-links (0 'org-link t))) - (if (memq 'date lk) '(org-activate-dates (0 'org-date t))) - (if (memq 'footnote lk) '(org-activate-footnote-links)) + ;; Link related fontification. + '(org-activate-links) + (when (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend))) + (when (memq 'radio lk) '(org-activate-target-links (1 'org-link t))) + (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)) ;; Diary sexps. '("^&?%%(.*\\|<%%([^>\n]*?>" (0 'org-sexp-date t)) ;; Macro - '("{{{.+}}}" (0 'org-macro t)) + '(org-fontify-macros) '(org-hide-wide-columns (0 nil append)) ;; TODO keyword (list (format org-heading-keyword-regexp-format @@ -6261,27 +6497,24 @@ needs to be inserted at a specific position in the font-lock sequence.") ;; Tags '(org-font-lock-add-tag-faces) ;; Tags groups - (if (and org-group-tags org-tag-groups-alist) - (list (concat org-outline-regexp-bol ".+\\(:" - (regexp-opt (mapcar 'car org-tag-groups-alist)) - ":\\).*$") - '(1 'org-tag-group prepend))) + (when (and org-group-tags org-tag-groups-alist) + (list (concat org-outline-regexp-bol ".+\\(:" + (regexp-opt (mapcar 'car org-tag-groups-alist)) + ":\\).*$") + '(1 'org-tag-group prepend))) ;; Special keywords (list (concat "\\<" org-deadline-string) '(0 'org-special-keyword t)) (list (concat "\\<" org-scheduled-string) '(0 'org-special-keyword t)) (list (concat "\\<" org-closed-string) '(0 'org-special-keyword t)) (list (concat "\\<" org-clock-string) '(0 'org-special-keyword t)) ;; Emphasis - (if em - (if (featurep 'xemacs) - '(org-do-emphasis-faces (0 nil append)) - '(org-do-emphasis-faces))) + (when em '(org-do-emphasis-faces)) ;; Checkboxes '("^[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)" 1 'org-checkbox prepend) - (if (cdr (assq 'checkbox org-list-automatic-rules)) - '("\\[\\([0-9]*%\\)\\]\\|\\[\\([0-9]*\\)/\\([0-9]*\\)\\]" - (0 (org-get-checkbox-statistics-face) t))) + (when (cdr (assq 'checkbox org-list-automatic-rules)) + '("\\[\\([0-9]*%\\)\\]\\|\\[\\([0-9]*\\)/\\([0-9]*\\)\\]" + (0 (org-get-checkbox-statistics-face) t))) ;; Description list items '("^[ \t]*[-+*][ \t]+\\(.*?[ \t]+::\\)\\([ \t]+\\|$\\)" 1 'org-list-dt prepend) @@ -6297,83 +6530,92 @@ needs to be inserted at a specific position in the font-lock sequence.") ;; Code '(org-activate-code (1 'org-code t)) ;; COMMENT - (list (format org-heading-keyword-regexp-format - (concat "\\(" - org-comment-string "\\|" org-quote-string - "\\)")) - '(2 'org-special-keyword t)) + (list (format + "^\\*+\\(?: +%s\\)?\\(?: +\\[#[A-Z0-9]\\]\\)? +\\(?9:%s\\)\\(?: \\|$\\)" + org-todo-regexp + org-comment-string) + '(9 'org-special-keyword t)) ;; Blocks and meta lines '(org-fontify-meta-lines-and-blocks)))) (setq org-font-lock-extra-keywords (delq nil org-font-lock-extra-keywords)) (run-hooks 'org-font-lock-set-keywords-hook) ;; Now set the full font-lock-keywords - (org-set-local 'org-font-lock-keywords org-font-lock-extra-keywords) - (org-set-local 'font-lock-defaults - '(org-font-lock-keywords t nil nil backward-paragraph)) - (kill-local-variable 'font-lock-keywords) nil)) + (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)) + (kill-local-variable 'font-lock-keywords) + nil)) (defun org-toggle-pretty-entities () "Toggle the composition display of entities as UTF8 characters." (interactive) - (org-set-local 'org-pretty-entities (not org-pretty-entities)) + (setq-local org-pretty-entities (not org-pretty-entities)) (org-restart-font-lock) (if org-pretty-entities (message "Entities are now displayed as UTF8 characters") (save-restriction (widen) - (org-decompose-region (point-min) (point-max)) + (decompose-region (point-min) (point-max)) (message "Entities are now displayed as plain text")))) -(defvar org-custom-properties-overlays nil +(defvar-local org-custom-properties-overlays nil "List of overlays used for custom properties.") -(make-variable-buffer-local 'org-custom-properties-overlays) (defun org-toggle-custom-properties-visibility () "Display or hide properties in `org-custom-properties'." (interactive) (if org-custom-properties-overlays - (progn (mapc 'delete-overlay org-custom-properties-overlays) + (progn (mapc #'delete-overlay org-custom-properties-overlays) (setq org-custom-properties-overlays nil)) - (unless (not org-custom-properties) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward org-property-re nil t) - (mapc (lambda(p) - (when (equal p (substring (match-string 1) 1 -1)) - (let ((o (make-overlay (match-beginning 0) (1+ (match-end 0))))) - (overlay-put o 'invisible t) - (overlay-put o 'org-custom-property t) - (push o org-custom-properties-overlays)))) - org-custom-properties))))))) + (when org-custom-properties + (org-with-wide-buffer + (goto-char (point-min)) + (let ((regexp (org-re-property (regexp-opt org-custom-properties) t t))) + (while (re-search-forward regexp nil t) + (let ((end (cdr (save-match-data (org-get-property-block))))) + (when (and end (< (point) end)) + ;; Hide first custom property in current drawer. + (let ((o (make-overlay (match-beginning 0) (1+ (match-end 0))))) + (overlay-put o 'invisible t) + (overlay-put o 'org-custom-property t) + (push o org-custom-properties-overlays)) + ;; Hide additional custom properties in the same drawer. + (while (re-search-forward regexp end t) + (let ((o (make-overlay (match-beginning 0) (1+ (match-end 0))))) + (overlay-put o 'invisible t) + (overlay-put o 'org-custom-property t) + (push o org-custom-properties-overlays))))) + ;; Each entry is limited to a single property drawer. + (outline-next-heading))))))) (defun org-fontify-entities (limit) "Find an entity to fontify." (let (ee) (when org-pretty-entities (catch 'match + ;; "\_ "-family is left out on purpose. Only the first one, + ;; i.e., "\_ ", could be fontified anyway, and it would be + ;; confusing when adding a second white space character. (while (re-search-forward "\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\($\\|{}\\|[^[:alpha:]\n]\\)" limit t) - (if (and (not (org-in-indented-comment-line)) - (setq ee (org-entity-get (match-string 1))) - (= (length (nth 6 ee)) 1)) - (let* - ((end (if (equal (match-string 2) "{}") + (when (and (not (org-at-comment-p)) + (setq ee (org-entity-get (match-string 1))) + (= (length (nth 6 ee)) 1)) + (let* ((end (if (equal (match-string 2) "{}") (match-end 2) (match-end 1)))) - (add-text-properties - (match-beginning 0) end - (list 'font-lock-fontified t)) - (compose-region (match-beginning 0) end - (nth 6 ee) nil) - (backward-char 1) - (throw 'match t)))) + (add-text-properties + (match-beginning 0) end + (list 'font-lock-fontified t)) + (compose-region (match-beginning 0) end + (nth 6 ee) nil) + (backward-char 1) + (throw 'match t)))) nil)))) (defun org-fontify-like-in-org-mode (s &optional odd-levels) - "Fontify string S like in Org-mode." + "Fontify string S like in Org mode." (with-temp-buffer (insert s) (let ((org-odd-levels-only odd-levels)) @@ -6387,33 +6629,55 @@ needs to be inserted at a specific position in the font-lock sequence.") (defun org-get-level-face (n) "Get the right face for match N in font-lock matching of headlines." (setq org-l (- (match-end 2) (match-beginning 1) 1)) - (if org-odd-levels-only (setq org-l (1+ (/ org-l 2)))) + (when org-odd-levels-only (setq org-l (1+ (/ org-l 2)))) (if org-cycle-level-faces (setq org-f (nth (% (1- org-l) org-n-level-faces) org-level-faces)) (setq org-f (nth (1- (min org-l org-n-level-faces)) org-level-faces))) (cond ((eq n 1) (if org-hide-leading-stars 'org-hide org-f)) ((eq n 2) org-f) - (t (if org-level-color-stars-only nil org-f)))) + (t (unless org-level-color-stars-only org-f)))) +(defun org-face-from-face-or-color (context inherit face-or-color) + "Create a face list that inherits INHERIT, but sets the foreground color. +When FACE-OR-COLOR is not a string, just return it." + (if (stringp face-or-color) + (list :inherit inherit + (cdr (assoc context org-faces-easy-properties)) + face-or-color) + face-or-color)) (defun org-get-todo-face (kwd) "Get the right face for a TODO keyword KWD. If KWD is a number, get the corresponding match group." - (if (numberp kwd) (setq kwd (match-string kwd))) + (when (numberp kwd) (setq kwd (match-string kwd))) (or (org-face-from-face-or-color 'todo 'org-todo (cdr (assoc kwd org-todo-keyword-faces))) (and (member kwd org-done-keywords) 'org-done) 'org-todo)) -(defun org-face-from-face-or-color (context inherit face-or-color) - "Create a face list that inherits INHERIT, but sets the foreground color. -When FACE-OR-COLOR is not a string, just return it." - (if (stringp face-or-color) - (list :inherit inherit - (cdr (assoc context org-faces-easy-properties)) - face-or-color) - face-or-color)) +(defun org-get-priority-face (priority) + "Get the right face for PRIORITY. +PRIORITY is a character." + (or (org-face-from-face-or-color + 'priority 'org-priority (cdr (assq priority org-priority-faces))) + 'org-priority)) + +(defun org-get-tag-face (tag) + "Get the right face for TAG. +If TAG is a number, get the corresponding match group." + (let ((tag (if (wholenump tag) (match-string tag) tag))) + (or (org-face-from-face-or-color + 'tag 'org-tag (cdr (assoc tag org-tag-faces))) + 'org-tag))) + +(defun org-font-lock-add-priority-faces (limit) + "Add the special priority faces." + (while (re-search-forward "^\\*+ .*?\\(\\[#\\(.\\)\\]\\)" limit t) + (add-text-properties + (match-beginning 1) (match-end 1) + (list 'face (org-get-priority-face (string-to-char (match-string 2))) + 'font-lock-fontified t)))) (defun org-font-lock-add-tag-faces (limit) "Add the special tag faces." @@ -6424,39 +6688,18 @@ When FACE-OR-COLOR is not a string, just return it." 'font-lock-fontified t)) (backward-char 1)))) -(defun org-font-lock-add-priority-faces (limit) - "Add the special priority faces." - (while (re-search-forward "\\[#\\([A-Z0-9]\\)\\]" limit t) - (when (save-match-data (org-at-heading-p)) - (add-text-properties - (match-beginning 0) (match-end 0) - (list 'face (or (org-face-from-face-or-color - 'priority 'org-priority - (cdr (assoc (char-after (match-beginning 1)) - org-priority-faces))) - 'org-priority) - 'font-lock-fontified t))))) - -(defun org-get-tag-face (kwd) - "Get the right face for a TODO keyword KWD. -If KWD is a number, get the corresponding match group." - (if (numberp kwd) (setq kwd (match-string kwd))) - (or (org-face-from-face-or-color - 'tag 'org-tag (cdr (assoc kwd org-tag-faces))) - 'org-tag)) - -(defun org-unfontify-region (beg end &optional maybe_loudly) +(defun org-unfontify-region (beg end &optional _maybe_loudly) "Remove fontification and activation overlays from links." (font-lock-default-unfontify-region beg end) (let* ((buffer-undo-list t) (inhibit-read-only t) (inhibit-point-motion-hooks t) (inhibit-modification-hooks t) deactivate-mark buffer-file-name buffer-file-truename) - (org-decompose-region beg end) + (decompose-region beg end) (remove-text-properties beg end '(mouse-face t keymap t org-linked-text t invisible t intangible t - org-no-flyspell t org-emphasis t)) + org-emphasis t)) (org-remove-font-lock-display-properties beg end))) (defconst org-script-display '(((raise -0.3) (height 0.7)) @@ -6473,59 +6716,56 @@ and subscripts." (while (< beg end) (setq next (next-single-property-change beg 'display nil end) prop (get-text-property beg 'display)) - (if (member prop org-script-display) - (put-text-property beg next 'display nil)) + (when (member prop org-script-display) + (put-text-property beg next 'display nil)) (setq beg next)))) (defun org-raise-scripts (limit) "Add raise properties to sub/superscripts." - (when (and org-pretty-entities org-pretty-entities-include-sub-superscripts) - (if (re-search-forward - (if (eq org-use-sub-superscripts t) - org-match-substring-regexp - org-match-substring-with-braces-regexp) - limit t) - (let* ((pos (point)) table-p comment-p - (mpos (match-beginning 3)) - (emph-p (get-text-property mpos 'org-emphasis)) - (link-p (get-text-property mpos 'mouse-face)) - (keyw-p (eq 'org-special-keyword (get-text-property mpos 'face)))) - (goto-char (point-at-bol)) - (setq table-p (org-looking-at-p org-table-dataline-regexp) - comment-p (org-looking-at-p "^[ \t]*#[ +]")) - (goto-char pos) - ;; Handle a_b^c - (if (member (char-after) '(?_ ?^)) (goto-char (1- pos))) - (if (or comment-p emph-p link-p keyw-p) - t - (put-text-property (match-beginning 3) (match-end 0) - 'display - (if (equal (char-after (match-beginning 2)) ?^) - (nth (if table-p 3 1) org-script-display) - (nth (if table-p 2 0) org-script-display))) - (add-text-properties (match-beginning 2) (match-end 2) - (list 'invisible t - 'org-dwidth t 'org-dwidth-n 1)) - (if (and (eq (char-after (match-beginning 3)) ?{) - (eq (char-before (match-end 3)) ?})) - (progn - (add-text-properties - (match-beginning 3) (1+ (match-beginning 3)) - (list 'invisible t 'org-dwidth t 'org-dwidth-n 1)) - (add-text-properties - (1- (match-end 3)) (match-end 3) - (list 'invisible t 'org-dwidth t 'org-dwidth-n 1)))) - t))))) + (when (and org-pretty-entities org-pretty-entities-include-sub-superscripts + (re-search-forward + (if (eq org-use-sub-superscripts t) + org-match-substring-regexp + org-match-substring-with-braces-regexp) + limit t)) + (let* ((pos (point)) table-p comment-p + (mpos (match-beginning 3)) + (emph-p (get-text-property mpos 'org-emphasis)) + (link-p (get-text-property mpos 'mouse-face)) + (keyw-p (eq 'org-special-keyword (get-text-property mpos 'face)))) + (goto-char (point-at-bol)) + (setq table-p (looking-at-p org-table-dataline-regexp) + comment-p (looking-at-p "^[ \t]*#[ +]")) + (goto-char pos) + ;; Handle a_b^c + (when (member (char-after) '(?_ ?^)) (goto-char (1- pos))) + (unless (or comment-p emph-p link-p keyw-p) + (put-text-property (match-beginning 3) (match-end 0) + 'display + (if (equal (char-after (match-beginning 2)) ?^) + (nth (if table-p 3 1) org-script-display) + (nth (if table-p 2 0) org-script-display))) + (add-text-properties (match-beginning 2) (match-end 2) + (list 'invisible t + 'org-dwidth t 'org-dwidth-n 1)) + (if (and (eq (char-after (match-beginning 3)) ?{) + (eq (char-before (match-end 3)) ?})) + (progn + (add-text-properties + (match-beginning 3) (1+ (match-beginning 3)) + (list 'invisible t 'org-dwidth t 'org-dwidth-n 1)) + (add-text-properties + (1- (match-end 3)) (match-end 3) + (list 'invisible t 'org-dwidth t 'org-dwidth-n 1))))) + t))) ;;;; Visibility cycling, including org-goto and indirect buffer ;;; Cycling -(defvar org-cycle-global-status nil) -(make-variable-buffer-local 'org-cycle-global-status) +(defvar-local org-cycle-global-status nil) (put 'org-cycle-global-status 'org-state t) -(defvar org-cycle-subtree-status nil) -(make-variable-buffer-local 'org-cycle-subtree-status) +(defvar-local org-cycle-subtree-status nil) (put 'org-cycle-subtree-status 'org-state t) (defvar org-inlinetask-min-level) @@ -6537,52 +6777,58 @@ and subscripts." ;;;###autoload (defun org-cycle (&optional arg) - "TAB-action and visibility cycling for Org-mode. + "TAB-action and visibility cycling for Org mode. -This is the command invoked in Org-mode by the TAB key. Its main purpose -is outline visibility cycling, but it also invokes other actions +This is the command invoked in Org mode by the `TAB' key. Its main +purpose is outline visibility cycling, but it also invokes other actions in special contexts. -- When this function is called with a prefix argument, rotate the entire - buffer through 3 states (global cycling) +When this function is called with a `\\[universal-argument]' prefix, rotate \ +the entire +buffer through 3 states (global cycling) 1. OVERVIEW: Show only top-level headlines. 2. CONTENTS: Show all headlines of all levels, but no body text. 3. SHOW ALL: Show everything. - When called with two `C-u C-u' prefixes, switch to the startup visibility, - determined by the variable `org-startup-folded', and by any VISIBILITY - properties in the buffer. - When called with three `C-u C-u C-u' prefixed, show the entire buffer, - including any drawers. -- When inside a table, re-align the table and move to the next field. +With a `\\[universal-argument] \\[universal-argument]' prefix argument, \ +switch to the startup visibility, +determined by the variable `org-startup-folded', and by any VISIBILITY +properties in the buffer. -- When point is at the beginning of a headline, rotate the subtree started - by this line through 3 different states (local cycling) +With a `\\[universal-argument] \\[universal-argument] \ +\\[universal-argument]' prefix argument, show the entire buffer, including +any drawers. + +When inside a table, re-align the table and move to the next field. + +When point is at the beginning of a headline, rotate the subtree started +by this line through 3 different states (local cycling) 1. FOLDED: Only the main headline is shown. 2. CHILDREN: The main headline and the direct children are shown. From this state, you can move to one of the children and zoom in further. 3. SUBTREE: Show the entire subtree, including body text. - If there is no subtree, switch directly from CHILDREN to FOLDED. - -- When point is at the beginning of an empty headline and the variable - `org-cycle-level-after-item/entry-creation' is set, cycle the level - of the headline by demoting and promoting it to likely levels. This - speeds up creation document structure by pressing TAB once or several - times right after creating a new headline. - -- When there is a numeric prefix, go up to a heading with level ARG, do - a `show-subtree' and return to the previous cursor position. If ARG - is negative, go up that many levels. - -- When point is not at the beginning of a headline, execute the global - binding for TAB, which is re-indenting the line. See the option - `org-cycle-emulate-tab' for details. - -- Special case: if point is at the beginning of the buffer and there is - no headline in line 1, this function will act as if called with prefix arg - (C-u TAB, same as S-TAB) also when called without prefix arg. - But only if also the variable `org-cycle-global-at-bob' is t." +If there is no subtree, switch directly from CHILDREN to FOLDED. + +When point is at the beginning of an empty headline and the variable +`org-cycle-level-after-item/entry-creation' is set, cycle the level +of the headline by demoting and promoting it to likely levels. This +speeds up creation document structure by pressing `TAB' once or several +times right after creating a new headline. + +When there is a numeric prefix, go up to a heading with level ARG, do +a `show-subtree' and return to the previous cursor position. If ARG +is negative, go up that many levels. + +When point is not at the beginning of a headline, execute the global +binding for `TAB', which is re-indenting the line. See the option +`org-cycle-emulate-tab' for details. + +As a special case, if point is at the beginning of the buffer and there is +no headline in line 1, this function will act as if called with prefix arg +\(`\\[universal-argument] TAB', same as `S-TAB') also when called without \ +prefix arg, but only +if the variable `org-cycle-global-at-bob' is t." (interactive "P") (org-load-modules-maybe) (unless (or (run-hook-with-args-until-success 'org-tab-first-hook) @@ -6611,10 +6857,6 @@ in special contexts. org-cycle-hook)) (pos (point))) - (if (or bob-special (equal arg '(4))) - ;; special case: use global cycling - (setq arg t)) - (cond ((equal arg '(16)) @@ -6623,32 +6865,36 @@ in special contexts. (org-unlogged-message "Startup visibility, plus VISIBILITY properties")) ((equal arg '(64)) - (show-all) + (outline-show-all) (org-unlogged-message "Entire buffer visible, including drawers")) + ((equal arg '(4)) (org-cycle-internal-global)) + + ;; Try hiding block at point. + ((org-hide-block-toggle-maybe)) + ;; Try cdlatex TAB completion ((org-try-cdlatex-tab)) ;; Table: enter it or move to the next field. ((org-at-table-p 'any) (if (org-at-table.el-p) - (message "%s" "Use C-c ' to edit table.el tables") + (message "%s" (substitute-command-keys "\\<org-mode-map>\ +Use `\\[org-edit-special]' to edit table.el tables")) (if arg (org-table-edit-field t) (org-table-justify-field-maybe) (call-interactively 'org-table-next-field)))) - ((run-hook-with-args-until-success - 'org-tab-after-check-for-table-hook)) + ((run-hook-with-args-until-success 'org-tab-after-check-for-table-hook)) ;; Global cycling: delegate to `org-cycle-internal-global'. - ((eq arg t) (org-cycle-internal-global)) + (bob-special (org-cycle-internal-global)) ;; Drawers: delegate to `org-flag-drawer'. - ((and org-drawers org-drawer-regexp - (save-excursion - (beginning-of-line 1) - (looking-at org-drawer-regexp))) - (org-flag-drawer ; toggle block visibility + ((save-excursion + (beginning-of-line 1) + (looking-at org-drawer-regexp)) + (org-flag-drawer ; toggle block visibility (not (get-char-property (match-end 0) 'invisible)))) ;; Show-subtree, ARG levels up from here. @@ -6667,7 +6913,7 @@ in special contexts. ;; At an item/headline: delegate to `org-cycle-internal-local'. ((and (or (and org-cycle-include-plain-lists (org-at-item-p)) - (save-excursion (beginning-of-line 1) + (save-excursion (move-beginning-of-line 1) (looking-at org-outline-regexp))) (or (bolp) (not (eq org-cycle-emulate-tab 'exc-hl-bol)))) (org-cycle-internal-local)) @@ -6722,7 +6968,7 @@ in special contexts. (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) - (show-all) + (outline-show-all) (unless ga (org-unlogged-message "SHOW ALL")) (setq org-cycle-global-status 'all) (run-hook-with-args 'org-cycle-hook 'all)) @@ -6738,6 +6984,11 @@ in special contexts. (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) @@ -6765,15 +7016,10 @@ in special contexts. (org-list-search-forward (org-item-beginning-re) eos t))))) ;; Determine end invisible part of buffer (EOL) (beginning-of-line 2) - ;; XEmacs doesn't have `next-single-char-property-change' - (if (featurep 'xemacs) - (while (and (not (eobp)) ;; this is like `next-line' - (get-char-property (1- (point)) 'invisible)) - (beginning-of-line 2)) - (while (and (not (eobp)) ;; this is like `next-line' - (get-char-property (1- (point)) 'invisible)) - (goto-char (next-single-char-property-change (point) 'invisible)) - (and (eolp) (beginning-of-line 2)))) + (while (and (not (eobp)) ;This is like `next-line'. + (get-char-property (1- (point)) 'invisible)) + (goto-char (next-single-char-property-change (point) 'invisible)) + (and (eolp) (beginning-of-line 2))) (setq eol (point))) ;; Find out what to do next and set `this-command' (cond @@ -6786,7 +7032,7 @@ in special contexts. (save-excursion (goto-char eos) (outline-next-heading) - (if (outline-invisible-p) (org-flag-heading nil)))) + (when (org-invisible-p) (org-flag-heading nil)))) ((and (or (>= eol eos) (not (string-match "\\S-" (buffer-substring eol eos)))) (or has-children @@ -6798,7 +7044,7 @@ in special contexts. (if (org-at-item-p) (org-list-set-item-visibility (point-at-bol) struct 'children) (org-show-entry) - (org-with-limited-levels (show-children)) + (org-with-limited-levels (org-show-children)) ;; 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) @@ -6813,14 +7059,14 @@ in special contexts. (let* ((struct (org-list-struct)) (prevs (org-list-prevs-alist struct)) (end (org-list-get-bottom-point struct))) - (mapc (lambda (e) (org-list-set-item-visibility e struct 'folded)) - (org-list-get-all-items (point) struct prevs)) + (dolist (e (org-list-get-all-items (point) struct prevs)) + (org-list-set-item-visibility e struct 'folded)) (goto-char (if (< end eos) end eos))))))) (org-unlogged-message "CHILDREN") (save-excursion (goto-char eos) (outline-next-heading) - (if (outline-invisible-p) (org-flag-heading nil))) + (when (org-invisible-p) (org-flag-heading nil))) (setq org-cycle-subtree-status 'children) (unless (org-before-first-heading-p) (run-hook-with-args 'org-cycle-hook 'children))) @@ -6849,15 +7095,15 @@ in special contexts. ;;;###autoload (defun org-global-cycle (&optional arg) "Cycle the global visibility. For details see `org-cycle'. -With \\[universal-argument] prefix arg, switch to startup visibility. +With `\\[universal-argument]' prefix ARG, switch to startup visibility. With a numeric prefix, show all headlines up to that level." (interactive "P") (let ((org-cycle-include-plain-lists (if (derived-mode-p 'org-mode) org-cycle-include-plain-lists nil))) (cond ((integerp arg) - (show-all) - (hide-sublevels arg) + (outline-show-all) + (outline-hide-sublevels arg) (setq org-cycle-global-status 'contents)) ((equal arg '(4)) (org-set-startup-visibility) @@ -6874,9 +7120,9 @@ With a numeric prefix, show all headlines up to that level." (org-content)) ((or (eq org-startup-folded 'showeverything) (eq org-startup-folded nil)) - (show-all))) + (outline-show-all))) (unless (eq org-startup-folded 'showeverything) - (if org-hide-block-startup (org-hide-block-all)) + (when org-hide-block-startup (org-hide-block-all)) (org-set-visibility-according-to-property 'no-cleanup) (org-cycle-hide-archived-subtrees 'all) (org-cycle-hide-drawers 'all) @@ -6885,34 +7131,32 @@ With a numeric prefix, show all headlines up to that level." (defun org-set-visibility-according-to-property (&optional no-cleanup) "Switch subtree visibilities according to :VISIBILITY: property." (interactive) - (let (org-show-entry-below state) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - "^[ \t]*:VISIBILITY:[ \t]+\\([a-z]+\\)" - nil t) - (setq state (match-string 1)) - (save-excursion - (org-back-to-heading t) - (hide-subtree) - (org-reveal) - (cond - ((equal state '("fold" "folded")) - (hide-subtree)) - ((equal state "children") - (org-show-hidden-entry) - (show-children)) - ((equal state "content") - (save-excursion - (save-restriction - (org-narrow-to-subtree) - (org-content)))) - ((member state '("all" "showall")) - (show-subtree))))) - (unless no-cleanup - (org-cycle-hide-archived-subtrees 'all) - (org-cycle-hide-drawers 'all) - (org-cycle-show-empty-lines 'all))))) + (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)) + ((equal state "children") + (org-show-hidden-entry) + (org-show-children)) + ((equal state "content") + (save-excursion + (save-restriction + (org-narrow-to-subtree) + (org-content)))) + ((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 @@ -6928,11 +7172,10 @@ results." (let ((level (save-excursion (goto-char (point-min)) - (if (re-search-forward (concat "^" outline-regexp) nil t) - (progn - (goto-char (match-beginning 0)) - (funcall outline-level)))))) - (and level (hide-sublevels level))))) + (when (re-search-forward (concat "^" outline-regexp) nil t) + (goto-char (match-beginning 0)) + (funcall outline-level))))) + (and level (outline-hide-sublevels level))))) (defun org-content (&optional arg) "Show all headlines in the buffer, like a table of contents. @@ -6950,9 +7193,9 @@ With numerical argument N, show content up to level N." t) (looking-at org-outline-regexp)) (if (integerp arg) - (show-children (1- arg)) - (show-branches)) - (if (bobp) (throw 'exit nil)))))) + (org-show-children (1- arg)) + (outline-show-branches)) + (when (bobp) (throw 'exit nil)))))) (defun org-optimize-window-after-visibility-change (state) "Adjust the window after a change in outline visibility. @@ -6967,13 +7210,11 @@ This function is the default value of the hook `org-cycle-hook'." (defun org-remove-empty-overlays-at (pos) "Remove outline overlays that do not contain non-white stuff." - (mapc - (lambda (o) - (and (eq 'outline (overlay-get o 'invisible)) - (not (string-match "\\S-" (buffer-substring (overlay-start o) - (overlay-end o)))) - (delete-overlay o))) - (overlays-at pos))) + (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." @@ -6991,7 +7232,7 @@ This function is the default value of the hook `org-cycle-hook'." (point-at-eol) (point)))) (level (looking-at "\\*+")) - (re (if level (concat "^" (regexp-quote (match-string 0)) " ")))) + (re (when level (concat "^" (regexp-quote (match-string 0)) " ")))) (save-excursion (save-restriction (narrow-to-region beg end) @@ -6999,10 +7240,10 @@ This function is the default value of the hook `org-cycle-hook'." ;; Properly fold already folded siblings (goto-char (point-min)) (while (re-search-forward re nil t) - (if (and (not (outline-invisible-p)) - (save-excursion - (goto-char (point-at-eol)) (outline-invisible-p))) - (hide-entry)))) + (when (and (not (org-invisible-p)) + (save-excursion + (goto-char (point-at-eol)) (org-invisible-p))) + (outline-hide-entry)))) (org-cycle-show-empty-lines 'overview) (org-cycle-hide-drawers 'overview))))) @@ -7012,7 +7253,7 @@ The region to be covered depends on STATE when called through `org-cycle-hook'. Lisp program can use t for STATE to get the entire buffer covered. Note that an empty line is only shown if there are at least `org-cycle-separator-lines' empty lines before the headline." - (when (not (= org-cycle-separator-lines 0)) + (when (/= org-cycle-separator-lines 0) (save-excursion (let* ((n (abs org-cycle-separator-lines)) (re (cond @@ -7021,38 +7262,34 @@ are at least `org-cycle-separator-lines' empty lines before the headline." (t (let ((ns (number-to-string (- n 2)))) (concat "^\\(?:[ \t]*\n\\)\\{" ns "," ns "\\}" "[ \t]*\\(\n[ \t]*\n\\*+\\) "))))) - beg end b e) + beg end) (cond ((memq state '(overview contents t)) (setq beg (point-min) end (point-max))) ((memq state '(children folded)) - (setq beg (point) end (progn (org-end-of-subtree t t) - (beginning-of-line 2) - (point))))) + (setq beg (point) + end (progn (org-end-of-subtree t t) + (line-beginning-position 2))))) (when beg (goto-char beg) (while (re-search-forward re end t) (unless (get-char-property (match-end 1) 'invisible) - (setq e (match-end 1)) - (if (< org-cycle-separator-lines 0) - (setq b (save-excursion - (goto-char (match-beginning 0)) - (org-back-over-empty-lines) - (if (save-excursion - (goto-char (max (point-min) (1- (point)))) - (org-at-heading-p)) - (1- (point)) - (point)))) - (setq b (match-beginning 1))) - (outline-flag-region b e nil))))))) + (let ((e (match-end 1)) + (b (if (>= org-cycle-separator-lines 0) + (match-beginning 1) + (save-excursion + (goto-char (match-beginning 0)) + (skip-chars-backward " \t\n") + (line-end-position))))) + (outline-flag-region b e nil)))))))) ;; Never hide empty lines at the end of the file. (save-excursion (goto-char (point-max)) (outline-previous-heading) (outline-end-of-heading) - (if (and (looking-at "[ \t\n]+") - (= (match-end 0) (point-max))) - (outline-flag-region (point) (match-end 0) nil)))) + (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." @@ -7061,28 +7298,28 @@ are at least `org-cycle-separator-lines' empty lines before the headline." (org-cycle-show-empty-lines context)))) (defun org-files-list () - "Return `org-agenda-files' list, plus all open org-mode files. + "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 - (if (and (derived-mode-p 'org-mode) (buffer-file-name)) - (let ((file (expand-file-name (buffer-file-name)))) - (unless (member file files) - (push file files)))))) + (when (and (derived-mode-p 'org-mode) (buffer-file-name)) + (cl-pushnew (expand-file-name (buffer-file-name)) files)))) files)) (defsubst org-entry-beginning-position () "Return the beginning position of the current entry." - (save-excursion (outline-back-to-heading t) (point))) + (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) - "Re-hide all drawers after a visibility state change." +(defun org-cycle-hide-drawers (state &optional exceptions) + "Re-hide all drawers after a visibility state change. +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 @@ -7093,36 +7330,39 @@ open and agenda-wise Org files." (save-excursion (outline-next-heading) (point)) (org-end-of-subtree t))))) (goto-char beg) - (while (re-search-forward org-drawer-regexp end t) - (org-flag-drawer t)))))) - -(defun org-cycle-hide-inline-tasks (state) - "Re-hide inline tasks when switching to `contents' or `children' -visibility state." - (case state - (contents - (when (org-bound-and-true-p org-inlinetask-min-level) - (hide-sublevels (1- org-inlinetask-min-level)))) - (children - (when (featurep 'org-inlinetask) - (save-excursion - (while (and (outline-next-heading) - (org-inlinetask-at-task-p)) - (org-inlinetask-toggle-visibility) - (org-inlinetask-goto-end))))))) - -(defun org-flag-drawer (flag) - "When FLAG is non-nil, hide the drawer we are within. -Otherwise make it visible." - (save-excursion - (beginning-of-line 1) - (when (looking-at "^[ \t]*:[a-zA-Z][a-zA-Z0-9]*:") - (let ((b (match-end 0))) - (if (re-search-forward - "^[ \t]*:END:" - (save-excursion (outline-next-heading) (point)) t) - (outline-flag-region b (point-at-eol) flag) - (user-error ":END: line missing at position %s" b)))))) + (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)))))) (defun org-subtree-end-visible-p () "Is the end of the current subtree visible?" @@ -7131,9 +7371,11 @@ Otherwise make it visible." (defun org-first-headline-recenter () "Move cursor to the first headline and recenter the headline." - (goto-char (point-min)) - (when (re-search-forward (concat "^\\(" org-outline-regexp "\\)") nil t) - (set-window-start (selected-window) (point-at-bol)))) + (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 @@ -7144,38 +7386,30 @@ 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) - (save-excursion - (save-restriction - (widen) - (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 (move-marker (make-marker) beg) - (move-marker (make-marker) end)) - (cons beg end))))) - (overlays-in (point-min) (point-max)))))))) + (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'." - (let (o) - (save-excursion - (save-restriction - (widen) - (show-all) - (mapc (lambda (c) - (outline-flag-region (car c) (cdr c) t)) - data))))) + (org-with-wide-buffer + (outline-show-all) + (dolist (c data) (outline-flag-region (car c) (cdr c) t)))) ;;; Folding of blocks -(defvar org-hide-block-overlays nil +(defvar-local org-hide-block-overlays nil "Overlays hiding blocks.") -(make-variable-buffer-local 'org-hide-block-overlays) (defun org-block-map (function &optional start end) "Call FUNCTION at the head of all source blocks in the current buffer. @@ -7192,74 +7426,85 @@ Optional arguments START and END can be used to limit the range." (defun org-hide-block-toggle-all () "Toggle the visibility of all blocks in the current buffer." - (org-block-map #'org-hide-block-toggle)) + (org-block-map 'org-hide-block-toggle)) (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)) + (org-block-map 'org-hide-block-toggle-maybe)) (defun org-show-block-all () "Unfold all blocks in the current buffer." (interactive) - (mapc 'delete-overlay org-hide-block-overlays) + (mapc #'delete-overlay org-hide-block-overlays) (setq org-hide-block-overlays nil)) (defun org-hide-block-toggle-maybe () - "Toggle visibility of block at point." + "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) - (let ((case-fold-search t)) - (if (save-excursion - (beginning-of-line 1) - (looking-at org-block-regexp)) - (progn (org-hide-block-toggle) - t) ;; to signal that we took action - nil))) ;; to signal that we did not + (ignore-errors (org-hide-block-toggle))) (defun org-hide-block-toggle (&optional force) - "Toggle the visibility of the current block." + "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) - (save-excursion - (beginning-of-line) - (if (re-search-forward org-block-regexp nil t) - (let ((start (- (match-beginning 4) 1)) ;; beginning of body - (end (match-end 0)) ;; end of entire body - ov) - (if (memq t (mapcar (lambda (overlay) - (eq (overlay-get overlay 'invisible) - 'org-hide-block)) - (overlays-at start))) - (if (or (not force) (eq force 'off)) - (mapc (lambda (ov) - (when (member 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))) - (overlays-at start))) - (setq 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 (member 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))) - (user-error "Not looking at a source block")))) - -;; org-tab-after-check-for-cycling-hook -(add-hook 'org-tab-first-hook 'org-hide-block-toggle-maybe) + (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 () (org-add-hook 'change-major-mode-hook - 'org-show-block-all 'append 'local))) + (lambda () (add-hook 'change-major-mode-hook + 'org-show-block-all 'append 'local))) ;;; Org-goto @@ -7305,7 +7550,7 @@ Optional arguments START and END can be used to limit the range." (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") +\[Up]/[Down]=next/prev headline TAB=cycle visibility [/] org-occur") (defvar org-goto-start-pos) ; dynamically scoped parameter @@ -7343,23 +7588,23 @@ With a prefix argument, use the alternative interface: e.g., if (selected-point (if (eq interface 'outline) (car (org-get-location (current-buffer) org-goto-help)) - (let ((pa (org-refile-get-location "Goto" nil nil t))) + (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) - (if (or (outline-invisible-p) (org-invisible-p2)) - (org-show-context 'org-goto))) + (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 the Org-mode buffer BUF. +(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 @@ -7372,7 +7617,7 @@ or nil." (save-window-excursion (delete-other-windows) (and (get-buffer "*org-goto*") (kill-buffer "*org-goto*")) - (org-pop-to-buffer-same-window + (pop-to-buffer-same-window (condition-case nil (make-indirect-buffer (current-buffer) "*org-goto*") (error (make-indirect-buffer (current-buffer) "*org-goto*")))) @@ -7390,11 +7635,9 @@ or nil." (setq buffer-read-only t) (if (and (boundp 'org-goto-start-pos) (integer-or-marker-p org-goto-start-pos)) - (let ((org-show-hierarchy-above t) - (org-show-siblings t) - (org-show-following-heading t)) - (goto-char org-goto-start-pos) - (and (outline-invisible-p) (org-show-context))) + (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") @@ -7405,8 +7648,14 @@ or nil." (defvar org-goto-local-auto-isearch-map (make-sparse-keymap)) (set-keymap-parent org-goto-local-auto-isearch-map isearch-mode-map) -(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) +;; `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." @@ -7414,9 +7663,12 @@ or nil." (while (if isearch-forward (search-forward string bound noerror) (search-backward string bound noerror)) - (when (let ((context (mapcar 'car (save-match-data (org-context))))) - (and (member :headline context) - (not (member :tags context)))) + (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 () @@ -7428,11 +7680,11 @@ or nil." (isearch-mode t) (isearch-process-search-char (string-to-char keys))))) -(defun org-goto-ret (&optional arg) +(defun org-goto-ret (&optional _arg) "Finish `org-goto' by going to the new location." (interactive "P") - (setq org-goto-selected-point (point) - org-goto-exit-command 'return) + (setq org-goto-selected-point (point)) + (setq org-goto-exit-command 'return) (throw 'exit nil)) (defun org-goto-left () @@ -7471,17 +7723,18 @@ or nil." (defun org-tree-to-indirect-buffer (&optional arg) "Create indirect buffer and narrow it to current subtree. + With a numerical prefix ARG, go up to this level and then take that tree. If ARG is negative, go up that many levels. If `org-indirect-buffer-display' is not `new-frame', the command removes the indirect buffer previously made with this command, to avoid proliferation of indirect buffers. However, when you call the command with a \ -\\[universal-argument] prefix, or -when `org-indirect-buffer-display' is `new-frame', the last buffer -is kept so that you can work with several indirect buffers at the same time. -If `org-indirect-buffer-display' is `dedicated-frame', the \ -\\[universal-argument] prefix also +`\\[universal-argument]' prefix, or +when `org-indirect-buffer-display' is `new-frame', the last buffer is kept +so that you can work with several indirect buffers at the same time. If +`org-indirect-buffer-display' is `dedicated-frame', the \ +`\\[universal-argument]' prefix also requests that a new frame be made for the new buffer, so that the dedicated frame is not changed." (interactive "P") @@ -7493,26 +7746,26 @@ frame is not changed." (org-back-to-heading t) (when (numberp arg) (setq level (org-outline-level)) - (if (< arg 0) (setq arg (+ level arg))) + (when (< arg 0) (setq arg (+ level arg))) (while (> (setq level (org-outline-level)) arg) (org-up-heading-safe))) (setq beg (point) - heading (org-get-heading)) + heading (org-get-heading 'no-tags)) (org-end-of-subtree t t) - (if (org-at-heading-p) (backward-char 1)) + (when (org-at-heading-p) (backward-char 1)) (setq end (point))) - (if (and (buffer-live-p org-last-indirect-buffer) - (not (eq org-indirect-buffer-display 'new-frame)) - (not arg)) - (kill-buffer org-last-indirect-buffer)) - (setq ibuf (org-get-indirect-buffer cbuf) + (when (and (buffer-live-p org-last-indirect-buffer) + (not (eq org-indirect-buffer-display 'new-frame)) + (not arg)) + (kill-buffer org-last-indirect-buffer)) + (setq ibuf (org-get-indirect-buffer cbuf heading) org-last-indirect-buffer ibuf) (cond ((or (eq org-indirect-buffer-display 'new-frame) (and arg (eq org-indirect-buffer-display 'dedicated-frame))) (select-frame (make-frame)) (delete-other-windows) - (org-pop-to-buffer-same-window ibuf) + (pop-to-buffer-same-window ibuf) (org-set-frame-title heading)) ((eq org-indirect-buffer-display 'dedicated-frame) (raise-frame @@ -7521,26 +7774,28 @@ frame is not changed." org-indirect-dedicated-frame) (setq org-indirect-dedicated-frame (make-frame))))) (delete-other-windows) - (org-pop-to-buffer-same-window ibuf) + (pop-to-buffer-same-window ibuf) (org-set-frame-title (concat "Indirect: " heading))) ((eq org-indirect-buffer-display 'current-window) - (org-pop-to-buffer-same-window ibuf)) + (pop-to-buffer-same-window ibuf)) ((eq org-indirect-buffer-display 'other-window) (pop-to-buffer ibuf)) (t (error "Invalid value"))) - (if (featurep 'xemacs) - (save-excursion (org-mode) (turn-on-font-lock))) (narrow-to-region beg end) - (show-all) + (outline-show-all) (goto-char pos) (run-hook-with-args 'org-cycle-hook 'all) (and (window-live-p cwin) (select-window cwin)))) -(defun org-get-indirect-buffer (&optional buffer) +(defun org-get-indirect-buffer (&optional buffer heading) (setq buffer (or buffer (current-buffer))) (let ((n 1) (base (buffer-name buffer)) bname) (while (buffer-live-p - (get-buffer (setq bname (concat base "-" (number-to-string n))))) + (get-buffer + (setq bname + (concat base "-" + (if heading (concat heading "-" (number-to-string n)) + (number-to-string n)))))) (setq n (1+ n))) (condition-case nil (make-indirect-buffer buffer bname 'clone) @@ -7548,57 +7803,70 @@ frame is not changed." (defun org-set-frame-title (title) "Set the title of the current frame to the string TITLE." - ;; FIXME: how to name a single frame in XEmacs??? - (unless (featurep 'xemacs) - (modify-frame-parameters (selected-frame) (list (cons 'name title))))) + (modify-frame-parameters (selected-frame) (list (cons 'name title)))) ;;;; Structure editing ;;; Inserting headlines -(defun org-previous-line-empty-p (&optional next) - "Is the previous line a blank line? -When NEXT is non-nil, check the next line instead." +(defun org--line-empty-p (n) + "Is the Nth next line empty? + +Counts the current line as N = 1 and the previous line as N = 0; +see `beginning-of-line'." (save-excursion (and (not (bobp)) - (or (beginning-of-line (if next 2 0)) t) + (or (beginning-of-line n) t) (save-match-data (looking-at "[ \t]*$"))))) -(defun org-insert-heading (&optional arg invisible-ok) - "Insert a new heading or an item with the same depth at point. - -If point is at the beginning of a heading or a list item, insert -a new heading or a new item above the current one. If point is -at the beginning of a normal line, turn the line into a heading. +(defun org-previous-line-empty-p () + "Is the previous line a blank line? +When NEXT is non-nil, check the next line instead." + (org--line-empty-p 0)) -If point is in the middle of a headline or a list item, split the -headline or the item and create a new headline/item with the text -in the current line after point \(see `org-M-RET-may-split-line' -on how to modify this behavior). +(defun org-next-line-empty-p () + "Is the previous line a blank line? +When NEXT is non-nil, check the next line instead." + (org--line-empty-p 2)) -With one universal prefix argument, set the user option -`org-insert-heading-respect-content' to t for the duration of -the command. This modifies the behavior described above in this -ways: on list items and at the beginning of normal lines, force -the insertion of a heading after the current subtree. +(defun org-insert-heading (&optional arg invisible-ok top) + "Insert a new heading or an item with the same depth at point. -With two universal prefix arguments, insert the heading at the -end of the grandparent subtree. For example, if point is within -a 2nd-level heading, then it will insert a 2nd-level heading at -the end of the 1st-level parent heading. +If point is at the beginning of a heading or a list item, insert +a new heading or a new item above the current one. When at the +beginning of a regular line of text, turn it into a heading. + +If point is in the middle of a line, split it and create a new +headline/item with the text in the current line after point (see +`org-M-RET-may-split-line' on how to modify this behavior). As +a special case, on a headline, splitting can only happen on the +title itself. E.g., this excludes breaking stars or tags. + +With a `\\[universal-argument]' prefix, set \ +`org-insert-heading-respect-content' to +a non-nil value for the duration of the command. This forces the +insertion of a heading after the current subtree, independently +on the location of point. + +With a `\\[universal-argument] \\[universal-argument]' prefix, \ +insert the heading at the end of the tree +above the current heading. For example, if point is within a +2nd-level heading, then it will insert a 2nd-level heading at +the end of the 1st-level parent subtree. When INVISIBLE-OK is set, stop at invisible headlines when going back. This is important for non-interactive uses of the -command." +command. + +When optional argument TOP is non-nil, insert a level 1 heading, +unconditionally." (interactive "P") - (if (org-called-interactively-p 'any) (org-reveal)) - (let ((itemp (org-in-item-p)) + (let ((itemp (and (not top) (org-in-item-p))) (may-split (org-get-alist-option org-M-RET-may-split-line 'headline)) (respect-content (or org-insert-heading-respect-content (equal arg '(4)))) - (initial-content "") - (adjust-empty-lines t)) + (initial-content "")) (cond @@ -7621,9 +7889,7 @@ command." (insert "\n* "))) (run-hooks 'org-insert-heading-hook)) - ((and itemp (not (member arg '((4) (16))))) - ;; Insert an item - (org-insert-item)) + ((and itemp (not (member arg '((4) (16)))) (org-insert-item))) (t ;; Maybe move at the end of the subtree @@ -7639,25 +7905,26 @@ command." (org-previous-line-empty-p) ;; We will decide later nil)) - ;; Get a level string to fall back on + ;; Get a level string to fall back on. (fix-level (if (org-before-first-heading-p) "*" (save-excursion (org-back-to-heading t) - (if (org-previous-line-empty-p) (setq empty-line-p t)) + (when (org-previous-line-empty-p) (setq empty-line-p t)) (looking-at org-outline-regexp) (make-string (1- (length (match-string 0))) ?*)))) (stars (save-excursion (condition-case nil - (progn + (if top "* " (org-back-to-heading invisible-ok) (when (and (not on-heading) (featurep 'org-inlinetask) (integerp org-inlinetask-min-level) (>= (length (match-string 0)) org-inlinetask-min-level)) - ;; Find a heading level before the inline task + ;; Find a heading level before the inline + ;; task. (while (and (setq level (org-up-heading-safe)) (>= level org-inlinetask-min-level))) (if (org-at-heading-p) @@ -7668,23 +7935,22 @@ command." (org-backward-heading-same-level 1 invisible-ok)) (= (point) (match-beginning 0))) - (not (org-previous-line-empty-p t))) + (not (org-next-line-empty-p))) (setq empty-line-p (or empty-line-p (org-previous-line-empty-p)))) (match-string 0)) (error (or fix-level "* "))))) (blank-a (cdr (assq 'heading org-blank-before-new-entry))) - (blank (if (eq blank-a 'auto) empty-line-p blank-a)) - pos hide-previous previous-pos) + (blank (if (eq blank-a 'auto) empty-line-p blank-a))) - ;; If we insert after content, move there and clean up whitespace - (when (and respect-content - (not (org-looking-at-p org-outline-regexp-bol))) + ;; If we insert after content, move there and clean up + ;; whitespace. + (when respect-content (if (not (org-before-first-heading-p)) (org-end-of-subtree nil t) (re-search-forward org-outline-regexp-bol) (beginning-of-line 0)) - (skip-chars-backward " \r\n") + (skip-chars-backward " \r\t\n") (and (not (looking-back "^\\*+" (line-beginning-position))) (looking-at "[ \t]+") (replace-match "")) (unless (eobp) (forward-char 1)) @@ -7692,14 +7958,17 @@ command." (unless (bobp) (backward-char 1)) (insert "\n"))) - ;; If we are splitting, grab the text that should be moved to the new headline + ;; If we are splitting, grab the text that should be moved + ;; to the new headline. (when may-split - (if (org-on-heading-p) - ;; This is a heading, we split intelligently (keeping tags) + (if (org-at-heading-p) + ;; This is a heading: split intelligently (keeping + ;; tags). (let ((pos (point))) - (goto-char (point-at-bol)) - (unless (looking-at org-complex-heading-regexp) - (error "This should not happen")) + (beginning-of-line) + (let ((case-fold-search nil)) + (unless (looking-at org-complex-heading-regexp) + (error "This should not happen"))) (when (and (match-beginning 4) (> pos (match-beginning 4)) (< pos (match-end 4))) @@ -7708,31 +7977,35 @@ command." (delete-region (point) (match-end 4)) (if (looking-at "[ \t]*$") (replace-match "") - (insert (make-string (length initial-content) ?\ ))) + (insert (make-string (length initial-content) ?\s))) (setq initial-content (org-trim initial-content))) (goto-char pos)) - ;; a normal line + ;; A normal line. (setq initial-content - (org-trim (buffer-substring (point) (point-at-eol)))) - (delete-region (point) (point-at-eol)))) + (org-trim + (delete-and-extract-region (point) (line-end-position)))))) - ;; If we are at the beginning of the line, insert before it. Else after + ;; If we are at the beginning of the line, insert before it. + ;; Otherwise, after it. (cond ((and (bolp) (looking-at "[ \t]*$"))) - ((and (bolp) (not (looking-at "[ \t]*$"))) - (open-line 1)) - (t - (goto-char (point-at-eol)) - (insert "\n"))) + ((bolp) (save-excursion (insert "\n"))) + (t (end-of-line) + (insert "\n"))) ;; Insert the new heading (insert stars) (just-one-space) (insert initial-content) - (when adjust-empty-lines - (if (or (not blank) - (and blank (not (org-previous-line-empty-p)))) - (org-N-empty-lines-before-current (if blank 1 0)))) + (unless (and blank (org-previous-line-empty-p)) + (org-N-empty-lines-before-current (if blank 1 0))) + ;; Adjust visibility, which may be messed up if we removed + ;; blank lines while previous entry was hidden. + (let ((bol (line-beginning-position))) + (dolist (o (overlays-at (1- bol))) + (when (and (eq (overlay-get o 'invisible) 'outline) + (eq (overlay-end o) bol)) + (move-overlay o (overlay-start o) (1- bol))))) (run-hooks 'org-insert-heading-hook))))))) (defun org-N-empty-lines-before-current (N) @@ -7752,20 +8025,23 @@ When NO-TAGS is non-nil, don't include tags. When NO-TODO is non-nil, don't include TODO keywords." (save-excursion (org-back-to-heading t) - (cond - ((and no-tags no-todo) - (looking-at org-complex-heading-regexp) - (match-string 4)) - (no-tags - (looking-at (concat org-outline-regexp - "\\(.*?\\)" - "\\(?:[ \t]+:[[:alnum:]:_@#%]+:\\)?[ \t]*$")) - (match-string 1)) - (no-todo - (looking-at org-todo-line-regexp) - (match-string 3)) - (t (looking-at org-heading-regexp) - (match-string 2))))) + (let ((case-fold-search nil)) + (cond + ((and no-tags no-todo) + (looking-at org-complex-heading-regexp) + ;; Return value has to be a string, but match group 4 is + ;; optional. + (or (match-string 4) "")) + (no-tags + (looking-at (concat org-outline-regexp + "\\(.*?\\)" + "\\(?:[ \t]+:[[:alnum:]:_@#%]+:\\)?[ \t]*$")) + (match-string 1)) + (no-todo + (looking-at org-todo-line-regexp) + (match-string 3)) + (t (looking-at org-heading-regexp) + (match-string 2)))))) (defvar orgstruct-mode) ; defined below @@ -7780,24 +8056,24 @@ This is a list with the following elements: - the tags string, or nil." (save-excursion (org-back-to-heading t) - (if (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))) - (org-match-string-no-properties 2) - (and (match-end 3) (aref (match-string 3) 2)) - (org-match-string-no-properties 4) - (org-match-string-no-properties 5)))))) + (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)))))) (defun org-get-entry () "Get the entry text, after heading, entire subtree." @@ -7805,6 +8081,24 @@ This is a list with the following elements: (org-back-to-heading t) (buffer-substring (point-at-bol 2) (org-end-of-subtree t)))) +(defun org-edit-headline (&optional heading) + "Edit the current headline. +Set it to HEADING when provided." + (interactive) + (org-with-wide-buffer + (org-back-to-heading t) + (let ((case-fold-search nil)) + (when (looking-at org-complex-heading-regexp) + (let* ((old (match-string-no-properties 4)) + (new (save-match-data + (org-trim (or heading (read-string "Edit: " old)))))) + (unless (equal old new) + (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) + (when (looking-at "[ \t]*$") (replace-match "")))))))) + (defun org-insert-heading-after-current () "Insert a new heading with same level as current, after current subtree." (interactive) @@ -7825,9 +8119,14 @@ This is a list with the following elements: (defun org-insert-todo-heading (arg &optional force-heading) "Insert a new heading with the same level and TODO state as current heading. -If the heading has no TODO state, or if the state is DONE, use the first -state (TODO by default). Also with one prefix arg, force first state. With -two prefix args, force inserting at the end of the parent subtree." + +If the heading has no TODO state, or if the state is DONE, use +the first state (TODO by default). Also with one prefix arg, +force first state. With two prefix args, force inserting at the +end of the parent subtree. + +When called at a plain list item, insert a new item with an +unchecked check box." (interactive "P") (when (or force-heading (not (org-insert-item 'checkbox))) (org-insert-heading (or (and (equal arg '(16)) '(16)) @@ -7835,19 +8134,18 @@ two prefix args, force inserting at the end of the parent subtree." (save-excursion (org-back-to-heading) (outline-previous-heading) - (looking-at org-todo-line-regexp)) - (let* - ((new-mark-x - (if (or (equal arg '(4)) - (not (match-beginning 2)) - (member (match-string 2) org-done-keywords)) - (car org-todo-keywords-1) - (match-string 2))) - (new-mark - (or - (run-hook-with-args-until-success - 'org-todo-get-default-hook new-mark-x nil) - new-mark-x))) + (let ((case-fold-search nil)) (looking-at org-todo-line-regexp))) + (let* ((new-mark-x + (if (or (equal arg '(4)) + (not (match-beginning 2)) + (member (match-string 2) org-done-keywords)) + (car org-todo-keywords-1) + (match-string 2))) + (new-mark + (or + (run-hook-with-args-until-success + 'org-todo-get-default-hook new-mark-x nil) + new-mark-x))) (beginning-of-line 1) (and (looking-at org-outline-regexp) (goto-char (match-end 0)) (if org-treat-insert-todo-heading-as-state-change @@ -7895,18 +8193,17 @@ See also `org-promote'." (org-fix-position-after-promote)) (defun org-demote-subtree () - "Demote the entire subtree. See `org-demote'. -See also `org-promote'." + "Demote the entire subtree. +See `org-demote' and `org-promote'." (interactive) (save-excursion (org-with-limited-levels (org-map-tree 'org-demote))) (org-fix-position-after-promote)) - (defun org-do-promote () "Promote the current heading higher up the tree. -If the region is active in `transient-mark-mode', promote all headings -in the region." +If the region is active in `transient-mark-mode', promote all +headings in the region." (interactive) (save-excursion (if (org-region-active-p) @@ -7916,8 +8213,8 @@ in the region." (defun org-do-demote () "Demote the current heading lower down the tree. -If the region is active in `transient-mark-mode', demote all headings -in the region." +If the region is active in `transient-mark-mode', demote all +headings in the region." (interactive) (save-excursion (if (org-region-active-p) @@ -7926,23 +8223,24 @@ in the region." (org-fix-position-after-promote)) (defun org-fix-position-after-promote () - "Make sure that after pro/demotion cursor position is right." + "Fix cursor position and indentation after demoting/promoting." (let ((pos (point))) (when (save-excursion - (beginning-of-line 1) - (looking-at org-todo-line-regexp) - (or (equal pos (match-end 1)) (equal pos (match-end 2)))) + (beginning-of-line) + (let ((case-fold-search nil)) (looking-at org-todo-line-regexp)) + (or (eq pos (match-end 1)) (eq pos (match-end 2)))) (cond ((eobp) (insert " ")) ((eolp) (insert " ")) - ((equal (char-after) ?\ ) (forward-char 1)))))) + ((equal (char-after) ?\s) (forward-char 1)))))) (defun org-current-level () "Return the level of the current entry, or nil if before the first headline. -The level is the number of stars at the beginning of the headline." - (save-excursion - (org-with-limited-levels - (if (ignore-errors (org-back-to-heading t)) - (funcall outline-level))))) +The level is the number of stars at the beginning of the +headline. Use `org-reduced-level' to remove the effect of +`org-odd-levels'. Unlike to `org-outline-level', this function +ignores inlinetasks." + (let ((level (org-with-limited-levels (org-outline-level)))) + (and (> level 0) level))) (defun org-get-previous-line-level () "Return the outline depth of the last headline before the current line. @@ -7978,50 +8276,39 @@ even level numbers will become the next higher odd number." ((< change 0) (max 1 (1+ (* 2 (/ (+ level (* 2 change)) 2)))))) (max 1 (+ level (or change 0))))) -(if (boundp 'define-obsolete-function-alias) - (if (or (featurep 'xemacs) (< emacs-major-version 23)) - (define-obsolete-function-alias 'org-get-legal-level - 'org-get-valid-level) - (define-obsolete-function-alias 'org-get-legal-level - 'org-get-valid-level "23.1"))) - (defun org-promote () - "Promote the current heading higher up the tree. -If the region is active in `transient-mark-mode', promote all headings -in the region." - (org-back-to-heading t) - (let* ((level (save-match-data (funcall outline-level))) - (after-change-functions (remove 'flyspell-after-change-function - after-change-functions)) - (up-head (concat (make-string (org-get-valid-level level -1) ?*) " ")) - (diff (abs (- level (length up-head) -1)))) - (cond ((and (= level 1) org-called-with-limited-levels - org-allow-promoting-top-level-subtree) - (replace-match "# " nil t)) - ((= level 1) - (user-error "Cannot promote to level 0. UNDO to recover if necessary")) - (t (replace-match up-head nil t))) - ;; Fixup tag positioning - (unless (= level 1) - (and org-auto-align-tags (org-set-tags nil 'ignore-column)) - (if org-adapt-indentation (org-fixup-indentation (- diff)))) - (run-hooks 'org-after-promote-entry-hook))) + "Promote the current heading higher up the tree." + (org-with-wide-buffer + (org-back-to-heading t) + (let* ((after-change-functions (remq 'flyspell-after-change-function + after-change-functions)) + (level (save-match-data (funcall outline-level))) + (up-head (concat (make-string (org-get-valid-level level -1) ?*) " ")) + (diff (abs (- level (length up-head) -1)))) + (cond + ((and (= level 1) org-allow-promoting-top-level-subtree) + (replace-match "# " nil t)) + ((= level 1) + (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-adapt-indentation (org-fixup-indentation (- diff)))) + (run-hooks 'org-after-promote-entry-hook)))) (defun org-demote () - "Demote the current heading lower down the tree. -If the region is active in `transient-mark-mode', demote all headings -in the region." - (org-back-to-heading t) - (let* ((level (save-match-data (funcall outline-level))) - (after-change-functions (remove 'flyspell-after-change-function - after-change-functions)) - (down-head (concat (make-string (org-get-valid-level level 1) ?*) " ")) - (diff (abs (- level (length down-head) -1)))) - (replace-match down-head nil t) - ;; Fixup tag positioning - (and org-auto-align-tags (org-set-tags nil 'ignore-column)) - (if org-adapt-indentation (org-fixup-indentation diff)) - (run-hooks 'org-after-demote-entry-hook))) + "Demote the current heading lower down the tree." + (org-with-wide-buffer + (org-back-to-heading t) + (let* ((after-change-functions (remq 'flyspell-after-change-function + after-change-functions)) + (level (save-match-data (funcall outline-level))) + (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-adapt-indentation (org-fixup-indentation diff)) + (run-hooks 'org-after-demote-entry-hook)))) (defun org-cycle-level () "Cycle the level of an empty headline through possible states. @@ -8036,32 +8323,32 @@ After top level, it switches back to sibling level." (cond ;; If first headline in file, promote to top-level. ((= prev-level 0) - (loop repeat (/ (- cur-level 1) (org-level-increment)) - do (org-do-promote))) + (cl-loop repeat (/ (- cur-level 1) (org-level-increment)) + do (org-do-promote))) ;; If same level as prev, demote one. ((= prev-level cur-level) (org-do-demote)) ;; If parent is top-level, promote to top level if not already. ((= prev-level 1) - (loop repeat (/ (- cur-level 1) (org-level-increment)) - do (org-do-promote))) + (cl-loop repeat (/ (- cur-level 1) (org-level-increment)) + do (org-do-promote))) ;; If top-level, return to prev-level. ((= cur-level 1) - (loop repeat (/ (- prev-level 1) (org-level-increment)) - do (org-do-demote))) + (cl-loop repeat (/ (- prev-level 1) (org-level-increment)) + do (org-do-demote))) ;; If less than prev-level, promote one. ((< cur-level prev-level) (org-do-promote)) ;; If deeper than prev-level, promote until higher than ;; prev-level. ((> cur-level prev-level) - (loop repeat (+ 1 (/ (- cur-level prev-level) (org-level-increment))) - do (org-do-promote)))) + (cl-loop repeat (+ 1 (/ (- cur-level prev-level) (org-level-increment))) + do (org-do-promote)))) t)))) (defun org-map-tree (fun) "Call FUN for every heading underneath the current one." - (org-back-to-heading) + (org-back-to-heading t) (let ((level (funcall outline-level))) (save-excursion (funcall fun) @@ -8077,39 +8364,123 @@ After top level, it switches back to sibling level." (save-excursion (setq end (copy-marker end)) (goto-char beg) - (if (and (re-search-forward org-outline-regexp-bol nil t) - (< (point) end)) - (funcall fun)) + (when (and (re-search-forward org-outline-regexp-bol nil t) + (< (point) end)) + (funcall fun)) (while (and (progn (outline-next-heading) (< (point) end)) (not (eobp))) (funcall fun))))) -(defvar org-property-end-re) ; silence byte-compiler (defun org-fixup-indentation (diff) "Change the indentation in the current entry by DIFF. -However, if any line in the current entry has no indentation, or if it -would end up with no indentation after the change, nothing at all is done." - (save-excursion - (let ((end (save-excursion (outline-next-heading) - (point-marker))) - (prohibit (if (> diff 0) - "^\\S-" - (concat "^ \\{0," (int-to-string (- diff)) "\\}\\S-"))) - col) - (unless (save-excursion (end-of-line 1) - (re-search-forward prohibit end t)) - (while (and (< (point) end) - (re-search-forward "^[ \t]+" end t)) - (goto-char (match-end 0)) - (setq col (current-column)) - (if (< diff 0) (replace-match "")) - (org-indent-to-column (+ diff col)))) - (move-marker end nil)))) + +DIFF is an integer. Indentation is done according to the +following rules: + + - Planning information and property drawers are always indented + according to the new level of the headline; + + - Footnote definitions and their contents are ignored; + + - Inlinetasks' boundaries are not shifted; + + - Empty lines are ignored; + + - Other lines' indentation are shifted by DIFF columns, unless + it would introduce a structural change in the document, in + which case no shifting is done at all. + +Assume point is at a heading or an inlinetask beginning." + (org-with-wide-buffer + (narrow-to-region (line-beginning-position) + (save-excursion + (if (org-with-limited-levels (org-at-heading-p)) + (org-with-limited-levels (outline-next-heading)) + (org-inlinetask-goto-end)) + (point))) + (forward-line) + ;; Indent properly planning info and property drawer. + (when (looking-at-p org-planning-line-re) + (org-indent-line) + (forward-line)) + (when (looking-at org-property-drawer-re) + (goto-char (match-end 0)) + (forward-line) + (save-excursion (org-indent-region (match-beginning 0) (match-end 0)))) + (catch 'no-shift + (when (zerop diff) (throw 'no-shift nil)) + ;; If DIFF is negative, first check if a shift is possible at all + ;; (e.g., it doesn't break structure). This can only happen if + ;; some contents are not properly indented. + (let ((case-fold-search t)) + (when (< diff 0) + (let ((diff (- diff)) + (forbidden-re (concat org-outline-regexp + "\\|" + (substring org-footnote-definition-re 1)))) + (save-excursion + (while (not (eobp)) + (cond + ((looking-at-p "[ \t]*$") (forward-line)) + ((and (looking-at-p org-footnote-definition-re) + (let ((e (org-element-at-point))) + (and (eq (org-element-type e) 'footnote-definition) + (goto-char (org-element-property :end e)))))) + ((looking-at-p org-outline-regexp) (forward-line)) + ;; Give up if shifting would move before column 0 or + ;; if it would introduce a headline or a footnote + ;; definition. + (t + (skip-chars-forward " \t") + (let ((ind (current-column))) + (when (or (< ind diff) + (and (= ind diff) (looking-at-p forbidden-re))) + (throw 'no-shift nil))) + ;; Ignore contents of example blocks and source + ;; blocks if their indentation is meant to be + ;; preserved. Jump to block's closing line. + (beginning-of-line) + (or (and (looking-at-p "[ \t]*#\\+BEGIN_\\(EXAMPLE\\|SRC\\)") + (let ((e (org-element-at-point))) + (and (memq (org-element-type e) + '(example-block src-block)) + (or org-src-preserve-indentation + (org-element-property :preserve-indent e)) + (goto-char (org-element-property :end e)) + (progn (skip-chars-backward " \r\t\n") + (beginning-of-line) + t)))) + (forward-line)))))))) + ;; Shift lines but footnote definitions, inlinetasks boundaries + ;; by DIFF. Also skip contents of source or example blocks + ;; when indentation is meant to be preserved. + (while (not (eobp)) + (cond + ((and (looking-at-p org-footnote-definition-re) + (let ((e (org-element-at-point))) + (and (eq (org-element-type e) 'footnote-definition) + (goto-char (org-element-property :end e)))))) + ((looking-at-p org-outline-regexp) (forward-line)) + ((looking-at-p "[ \t]*$") (forward-line)) + (t + (indent-line-to (+ (org-get-indentation) diff)) + (beginning-of-line) + (or (and (looking-at-p "[ \t]*#\\+BEGIN_\\(EXAMPLE\\|SRC\\)") + (let ((e (org-element-at-point))) + (and (memq (org-element-type e) + '(example-block src-block)) + (or org-src-preserve-indentation + (org-element-property :preserve-indent e)) + (goto-char (org-element-property :end e)) + (progn (skip-chars-backward " \r\t\n") + (beginning-of-line) + t)))) + (forward-line))))))))) (defun org-convert-to-odd-levels () - "Convert an org-mode file with all levels allowed to one with odd levels. + "Convert an Org file with all levels allowed to one with odd levels. This will leave level 1 alone, convert level 2 to level 3, level 3 to level 5 etc." (interactive) @@ -8125,7 +8496,7 @@ level 5 etc." (end-of-line 1)))))) (defun org-convert-to-oddeven-levels () - "Convert an org-mode file with only odd levels to one with odd/even levels. + "Convert an Org file with only odd levels to one with odd/even levels. This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a section with an even level, conversion would destroy the structure of the file. An error is signaled in this @@ -8134,7 +8505,7 @@ case." (goto-char (point-min)) ;; First check if there are no even levels (when (re-search-forward "^\\(\\*\\*\\)+ " nil t) - (org-show-context t) + (org-show-set-visibility 'canonical) (error "Not all levels are odd in this file. Conversion not possible")) (when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ") (let ((outline-regexp org-outline-regexp) @@ -8177,7 +8548,7 @@ case." (setq beg (point))) (save-match-data (save-excursion (outline-end-of-heading) - (setq folded (outline-invisible-p))) + (setq folded (org-invisible-p))) (progn (org-end-of-subtree nil t) (unless (eobp) (backward-char)))) (outline-next-heading) @@ -8196,12 +8567,12 @@ case." (progn (goto-char beg0) (user-error "Cannot move past superior level or buffer limit"))) (setq cnt (1- cnt))) - (if (> arg 0) - ;; Moving forward - still need to move over subtree - (progn (org-end-of-subtree t t) - (save-excursion - (org-back-over-empty-lines) - (or (bolp) (newline))))) + (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)) @@ -8230,9 +8601,9 @@ case." (insert (make-string (- ne-ins ne-beg) ?\n))) (move-marker ins-point nil) (if folded - (hide-subtree) + (outline-hide-subtree) (org-show-entry) - (show-children) + (org-show-children) (org-cycle-hide-drawers 'children)) (org-clean-visibility-after-subtree-move) ;; move back to the initial column we were at @@ -8264,7 +8635,7 @@ 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 (org-called-interactively-p 'any) + (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)) @@ -8273,11 +8644,14 @@ useful if the caller implements cut-and-paste as copy-then-paste-then-cut." (if nosubtrees (outline-next-heading) (save-excursion (outline-end-of-heading) - (setq folded (outline-invisible-p))) - (condition-case nil - (org-forward-heading-same-level (1- n) t) - (error nil)) + (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) @@ -8290,7 +8664,7 @@ useful if the caller implements cut-and-paste as copy-then-paste-then-cut." (if cut "Cut" "Copied") (length org-subtree-clip))))) -(defun org-paste-subtree (&optional level tree for-yank) +(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. @@ -8313,15 +8687,17 @@ If optional TREE is given, use this text instead of the kill ring. When FOR-YANK is set, this is called by `org-yank'. In this case, do not move back over whitespace before inserting, and move point to the end of -the inserted text when done." +the inserted text when done. + +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"))) + (substitute-command-keys + "The kill is not a (set of) tree(s) - please use \\[yank] to yank anyway"))) (org-with-limited-levels - (let* ((visp (not (outline-invisible-p))) + (let* ((visp (not (org-invisible-p))) (txt tree) (^re_ "\\(\\*+\\)[ \t]*") (old-level (if (string-match org-outline-regexp-bol txt) @@ -8364,22 +8740,22 @@ the inserted text when done." (org-odd-levels-only nil) beg end newend) ;; Remove the forced level indicator - (if force-level - (delete-region (point-at-bol) (point))) + (when force-level + (delete-region (point-at-bol) (point))) ;; Paste (beginning-of-line (if (bolp) 1 2)) (setq beg (point)) (and (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt)) (insert-before-markers txt) - (unless (string-match "\n\\'" txt) (insert "\n")) + (unless (string-suffix-p "\n" txt) (insert "\n")) (setq newend (point)) (org-reinstall-markers-in-region beg) (setq end (point)) (goto-char beg) (skip-chars-forward " \t\n\r") (setq beg (point)) - (if (and (outline-invisible-p) visp) - (save-excursion (outline-show-heading))) + (when (and (org-invisible-p) visp) + (save-excursion (outline-show-heading))) ;; Shift if necessary (unless (= shift 0) (save-restriction @@ -8389,15 +8765,16 @@ the inserted text when done." (setq shift (+ delta shift))) (goto-char (point-min)) (setq newend (point-max)))) - (when (or (org-called-interactively-p 'interactive) for-yank) + (when (or (called-interactively-p 'interactive) for-yank) (message "Clipboard pasted as level %d subtree" new-level)) - (if (and (not for-yank) ; in this case, org-yank will decide about folding - kill-ring - (eq org-subtree-clip (current-kill 0)) - org-subtree-clip-folded) - ;; The tree was folded before it was killed/copied - (hide-subtree)) - (and for-yank (goto-char newend))))) + (when (and (not for-yank) ; in this case, org-yank will decide about folding + kill-ring + (eq 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)))))) (defun org-kill-is-subtree-p (&optional txt) "Check if the current kill is an outline subtree, or a set of trees. @@ -8447,15 +8824,14 @@ called immediately, to move the markers with the entries." "Check if MARKER is between BEG and END. If yes, remember the marker and the distance to BEG." (when (and (marker-buffer marker) - (equal (marker-buffer marker) (current-buffer))) - (if (and (>= marker beg) (< marker end)) - (push (cons marker (- marker beg)) org-markers-to-move)))) + (equal (marker-buffer marker) (current-buffer)) + (>= marker beg) (< marker end)) + (push (cons marker (- marker beg)) org-markers-to-move))) (defun org-reinstall-markers-in-region (beg) "Move all remembered markers to their position relative to BEG." - (mapc (lambda (x) - (move-marker (car x) (+ beg (cdr x)))) - org-markers-to-move) + (dolist (x org-markers-to-move) + (move-marker (car x) (+ beg (cdr x)))) (setq org-markers-to-move nil)) (defun org-narrow-to-subtree () @@ -8467,7 +8843,7 @@ If yes, remember the marker and the distance to BEG." (narrow-to-region (progn (org-back-to-heading t) (point)) (progn (org-end-of-subtree t t) - (if (and (org-at-heading-p) (not (eobp))) (backward-char 1)) + (when (and (org-at-heading-p) (not (eobp))) (backward-char 1)) (point))))))) (defun org-narrow-to-block () @@ -8480,10 +8856,6 @@ If yes, remember the marker and the distance to BEG." (narrow-to-region (car blockp) (cdr blockp)) (user-error "Not in a block")))) -(eval-when-compile - (defvar org-property-drawer-re)) - -(defvar org-property-start-re) ;; defined below (defun org-clone-subtree-with-time-shift (n &optional shift) "Clone the task (subtree) at point N times. The clones will be inserted as siblings. @@ -8500,6 +8872,9 @@ stamps in the subtree shifted for each clone produced. If SHIFT is nil or the empty string, time stamps will be left alone. The ID property of the original subtree is removed. +In each clone, all the CLOCK entries will be removed. This +prevents Org from considering that the clocked times overlap. + If the original subtree did contain time stamps with a repeater, the following will happen: - the repeater will be removed in each clone @@ -8510,80 +8885,86 @@ the following will happen: - the start days in the repeater in the original entry will be shifted to past the last clone. In this way you can spell out a number of instances of a repeating task, -and still retain the repeater to cover future instances of the task." +and still retain the repeater to cover future instances of the task. + +As described above, N+1 clones are produced when the original +subtree has a repeater. Setting N to 0, then, can be used to +remove the repeater from a subtree and create a shifted clone +with the original repeater." (interactive "nNumber of clones to produce: ") - (let ((shift - (or shift - (if (and (not (equal current-prefix-arg '(4))) - (save-excursion - (re-search-forward org-ts-regexp-both - (save-excursion - (org-end-of-subtree t) - (point)) t))) - (read-from-minibuffer - "Date shift per clone (e.g. +1w, empty to copy unchanged): ") - ""))) ;; No time shift - (n-no-remove -1) - (drawer-re org-drawer-regexp) - beg end template task idprop - shift-n shift-what doshift nmin nmax) - (if (not (and (integerp n) (> n 0))) - (error "Invalid number of replications %s" n)) - (if (and (setq doshift (and (stringp shift) (string-match "\\S-" shift))) - (not (string-match "\\`[ \t]*\\+?\\([0-9]+\\)\\([hdwmy]\\)[ \t]*\\'" - shift))) - (error "Invalid shift specification %s" shift)) - (when doshift - (setq shift-n (string-to-number (match-string 1 shift)) - shift-what (cdr (assoc (match-string 2 shift) - '(("d" . day) ("w" . week) - ("m" . month) ("y" . year)))))) - (if (eq shift-what 'week) (setq shift-n (* 7 shift-n) shift-what 'day)) - (setq nmin 1 nmax n) - (org-back-to-heading t) - (setq beg (point)) - (setq idprop (org-entry-get nil "ID")) - (org-end-of-subtree t t) - (or (bolp) (insert "\n")) - (setq end (point)) - (setq template (buffer-substring beg end)) - (when (and doshift - (string-match "<[^<>\n]+ [.+]?\\+[0-9]+[hdwmy][^<>\n]*>" template)) - (delete-region beg end) - (setq end beg) - (setq nmin 0 nmax (1+ nmax) n-no-remove nmax)) - (goto-char end) - (loop for n from nmin to nmax do - ;; prepare clone - (with-temp-buffer - (insert template) - (org-mode) - (goto-char (point-min)) - (org-show-subtree) - (and idprop (if org-clone-delete-id - (org-entry-delete nil "ID") - (org-id-get-create t))) - (unless (= n 0) - (while (re-search-forward "^[ \t]*CLOCK:.*$" nil t) - (kill-whole-line)) - (goto-char (point-min)) - (while (re-search-forward drawer-re nil t) - (mapc (lambda (d) - (org-remove-empty-drawer-at d (point))) - org-drawers))) - (goto-char (point-min)) - (when doshift - (while (re-search-forward org-ts-regexp-both nil t) - (org-timestamp-change (* n shift-n) shift-what)) - (unless (= n n-no-remove) - (goto-char (point-min)) - (while (re-search-forward org-ts-regexp nil t) - (save-excursion - (goto-char (match-beginning 0)) - (if (looking-at "<[^<>\n]+\\( +[.+]?\\+[0-9]+[hdwmy]\\)") - (delete-region (match-beginning 1) (match-end 1))))))) - (setq task (buffer-string))) - (insert task)) + (unless (wholenump n) (user-error "Invalid number of replications %s" n)) + (when (org-before-first-heading-p) (user-error "No subtree to clone")) + (let* ((beg (save-excursion (org-back-to-heading t) (point))) + (end-of-tree (save-excursion (org-end-of-subtree t t) (point))) + (shift + (or shift + (if (and (not (equal current-prefix-arg '(4))) + (save-excursion + (goto-char beg) + (re-search-forward org-ts-regexp-both end-of-tree t))) + (read-from-minibuffer + "Date shift per clone (e.g. +1w, empty to copy unchanged): ") + ""))) ;No time shift + (doshift + (and (org-string-nw-p shift) + (or (string-match "\\`[ \t]*\\+?\\([0-9]+\\)\\([dwmy]\\)[ \t]*\\'" + shift) + (user-error "Invalid shift specification %s" shift))))) + (goto-char end-of-tree) + (unless (bolp) (insert "\n")) + (let* ((end (point)) + (template (buffer-substring beg end)) + (shift-n (and doshift (string-to-number (match-string 1 shift)))) + (shift-what (pcase (and doshift (match-string 2 shift)) + (`nil nil) + ("d" 'day) + ("w" (setq shift-n (* 7 shift-n)) 'day) + ("m" 'month) + ("y" 'year) + (_ (error "Unsupported time unit")))) + (nmin 1) + (nmax n) + (n-no-remove -1) + (idprop (org-entry-get nil "ID"))) + (when (and doshift + (string-match-p "<[^<>\n]+ [.+]?\\+[0-9]+[hdwmy][^<>\n]*>" + template)) + (delete-region beg end) + (setq end beg) + (setq nmin 0) + (setq nmax (1+ nmax)) + (setq n-no-remove nmax)) + (goto-char end) + (cl-loop for n from nmin to nmax do + (insert + ;; Prepare clone. + (with-temp-buffer + (insert template) + (org-mode) + (goto-char (point-min)) + (org-show-subtree) + (and idprop (if org-clone-delete-id + (org-entry-delete nil "ID") + (org-id-get-create t))) + (unless (= n 0) + (while (re-search-forward org-clock-line-re nil t) + (delete-region (line-beginning-position) + (line-beginning-position 2))) + (goto-char (point-min)) + (while (re-search-forward org-drawer-regexp nil t) + (org-remove-empty-drawer-at (point)))) + (goto-char (point-min)) + (when doshift + (while (re-search-forward org-ts-regexp-both nil t) + (org-timestamp-change (* n shift-n) shift-what)) + (unless (= n n-no-remove) + (goto-char (point-min)) + (while (re-search-forward org-ts-regexp nil t) + (save-excursion + (goto-char (match-beginning 0)) + (when (looking-at "<[^<>\n]+\\( +[.+]?\\+[0-9]+[hdwmy]\\)") + (delete-region (match-beginning 1) (match-end 1))))))) + (buffer-string))))) (goto-char beg))) ;;; Outline Sorting @@ -8621,7 +9002,8 @@ hook gets called. When a region or a plain list is sorted, the cursor will be in the first entry of the sorted region/list.") (defun org-sort-entries - (&optional with-case sorting-type getkey-func compare-func property) + (&optional with-case sorting-type getkey-func compare-func property + interactive?) "Sort entries on a certain level of an outline tree. If there is an active region, the entries in the region are sorted. Else, if the cursor is before the first entry, sort the top-level items. @@ -8632,33 +9014,40 @@ a time stamp, by a property, by priority order, or by a custom function. The command prompts for the sorting type unless it has been given to the function through the SORTING-TYPE argument, which needs to be a character, -\(?n ?N ?a ?A ?t ?T ?s ?S ?d ?D ?p ?P ?o ?O ?r ?R ?f ?F). Here is the -precise meaning of each character: +\(?n ?N ?a ?A ?t ?T ?s ?S ?d ?D ?p ?P ?o ?O ?r ?R ?f ?F ?k ?K). Here is +the precise meaning of each character: -n Numerically, by converting the beginning of the entry/item to a number. a Alphabetically, ignoring the TODO keyword and the priority, if any. -o By order of TODO keywords. -t By date/time, either the first active time stamp in the entry, or, if - none exist, by the first inactive one. -s By the scheduled date/time. -d By deadline date/time. c By creation time, which is assumed to be the first inactive time stamp at the beginning of a line. +d By deadline date/time. +k By clocking time. +n Numerically, by converting the beginning of the entry/item to a number. +o By order of TODO keywords. p By priority according to the cookie. r By the value of a property. +s By scheduled date/time. +t By date/time, either the first active time stamp in the entry, or, if + none exist, by the first inactive one. Capital letters will reverse the sort order. If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies a function to be -called with point at the beginning of the record. It must return either -a string or a number that should serve as the sorting key for that record. +called with point at the beginning of the record. It must return a +value that is compatible with COMPARE-FUNC, the function used to +compare entries. Comparing entries ignores case by default. However, with an optional argument WITH-CASE, the sorting considers case as well. Sorting is done against the visible part of the headlines, it ignores hidden -links." - (interactive "P") +links. + +When sorting is done, call `org-after-sorting-entries-or-items-hook'. + +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 nil t)) (let ((case-func (if with-case 'identity 'downcase)) (cmstr ;; The clock marker is lost when using `sort-subr', let's @@ -8677,10 +9066,10 @@ links." (setq end (region-end) what "region") (goto-char (region-beginning)) - (if (not (org-at-heading-p)) (outline-next-heading)) + (unless (org-at-heading-p) (outline-next-heading)) (setq start (point))) ((or (org-at-heading-p) - (condition-case nil (progn (org-back-to-heading) t) (error nil))) + (ignore-errors (progn (org-back-to-heading) t))) ;; we will sort the children of the current headline (org-back-to-heading) (setq start (point) @@ -8691,7 +9080,7 @@ links." (point)) what "children") (goto-char start) - (show-subtree) + (outline-show-subtree) (outline-next-heading)) (t ;; we will sort the top-level entries in this file @@ -8707,7 +9096,7 @@ links." (setq end (point-max)) (setq what "top-level") (goto-char start) - (show-all))) + (outline-show-all))) (setq beg (point)) (when (>= beg end) (goto-char start) (user-error "Nothing to sort")) @@ -8717,32 +9106,34 @@ links." re (concat "^" (regexp-quote stars) " +") re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[ \t\n]") txt (buffer-substring beg end)) - (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n"))) - (if (and (not (equal stars "*")) (string-match re2 txt)) - (user-error "Region to sort contains a level above the first entry")) + (unless (equal (substring txt -1) "\n") (setq txt (concat txt "\n"))) + (when (and (not (equal stars "*")) (string-match re2 txt)) + (user-error "Region to sort contains a level above the first entry")) (unless sorting-type (message "Sort %s: [a]lpha [n]umeric [p]riority p[r]operty todo[o]rder [f]unc - [t]ime [s]cheduled [d]eadline [c]reated - A/N/P/R/O/F/T/S/D/C means reversed:" + [t]ime [s]cheduled [d]eadline [c]reated cloc[k]ing + A/N/P/R/O/F/T/S/D/C/K means reversed:" what) - (setq sorting-type (read-char-exclusive)) - - (unless getkey-func - (and (= (downcase sorting-type) ?f) - (setq getkey-func - (org-icompleting-read "Sort using function: " - obarray 'fboundp t nil nil)) - (setq getkey-func (intern getkey-func)))) - - (and (= (downcase sorting-type) ?r) - (not property) - (setq property - (org-icompleting-read "Property: " - (mapcar 'list (org-buffer-property-keys t)) - nil t)))) - + (setq sorting-type (read-char-exclusive))) + + (unless getkey-func + (and (= (downcase sorting-type) ?f) + (setq getkey-func + (or (and interactive? + (org-read-function + "Function for extracting keys: ")) + (error "Missing key extractor"))))) + + (and (= (downcase sorting-type) ?r) + (not property) + (setq property + (completing-read "Property: " + (mapcar #'list (org-buffer-property-keys t)) + nil t))) + + (when (member sorting-type '(?k ?K)) (org-clock-sum)) (message "Sorting entries...") (save-restriction @@ -8777,6 +9168,8 @@ links." (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) @@ -8807,22 +9200,29 @@ links." ((= dcst ?r) (or (org-entry-get nil property) "")) ((= dcst ?o) - (if (looking-at org-complex-heading-regexp) - (- 9999 (length (member (match-string 2) - org-todo-keywords-1))))) + (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)) - (if (stringp tmp) (setq tmp (funcall case-func tmp))) + (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) compare-func) - ((member dcst '(?p ?t ?s ?d ?c)) '<))))) + ((= 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)) '<))))) (run-hooks 'org-after-sorting-entries-or-items-hook) ;; Reset the clock marker if needed (when cmstr @@ -8832,60 +9232,18 @@ links." (move-marker org-clock-marker (point)))) (message "Sorting entries...done"))) -(defun org-do-sort (table what &optional with-case sorting-type) - "Sort TABLE of WHAT according to SORTING-TYPE. -The user will be prompted for the SORTING-TYPE if the call to this -function does not specify it. WHAT is only for the prompt, to indicate -what is being sorted. The sorting key will be extracted from -the car of the elements of the table. -If WITH-CASE is non-nil, the sorting will be case-sensitive." - (unless sorting-type - (message - "Sort %s: [a]lphabetic, [n]umeric, [t]ime. A/N/T means reversed:" - what) - (setq sorting-type (read-char-exclusive))) - (let ((dcst (downcase sorting-type)) - extractfun comparefun) - ;; Define the appropriate functions - (cond - ((= dcst ?n) - (setq extractfun 'string-to-number - comparefun (if (= dcst sorting-type) '< '>))) - ((= dcst ?a) - (setq extractfun (if with-case (lambda(x) (org-sort-remove-invisible x)) - (lambda(x) (downcase (org-sort-remove-invisible x)))) - comparefun (if (= dcst sorting-type) - 'string< - (lambda (a b) (and (not (string< a b)) - (not (string= a b))))))) - ((= dcst ?t) - (setq extractfun - (lambda (x) - (if (or (string-match org-ts-regexp x) - (string-match org-ts-regexp-both x)) - (float-time - (org-time-string-to-time (match-string 0 x))) - 0)) - comparefun (if (= dcst sorting-type) '< '>))) - (t (error "Invalid sorting type `%c'" sorting-type))) - - (sort (mapcar (lambda (x) (cons (funcall extractfun (car x)) (cdr x))) - table) - (lambda (a b) (funcall comparefun (car a) (car b)))))) - - ;;; 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. +;; integrate the Org mode structure editing commands. -;; This is really a hack, because the org-mode structure commands use +;; 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 +;; 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 @@ -8917,10 +9275,10 @@ 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 +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)." +defined by Org mode)." nil " OrgStruct" (make-sparse-keymap) (funcall (if orgstruct-mode 'add-to-invisibility-spec @@ -8937,40 +9295,38 @@ defined by Org-mode)." "Unconditionally turn on `orgstruct-mode'." (orgstruct-mode 1)) -(defvar org-fb-vars nil) -(make-variable-buffer-local 'org-fb-vars) +(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 +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) - (mapc (lambda(v) - (org-set-local (car v) - (if (eq (car-safe (cadr v)) 'quote) (cadadr v) (cadr v)))) - org-fb-vars)) + (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) - (mapc - (lambda (x) - (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) - (org-set-local var (if (eq (car-safe val) 'quote) (nth 1 val) val)))) - org-local-vars) - (org-set-local 'orgstruct-is-++ t)))) - -(defvar orgstruct-is-++ nil - "Is `orgstruct-mode' in ++ version in the current-buffer?") -(make-variable-buffer-local 'orgstruct-is-++) + (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++ () @@ -8999,6 +9355,7 @@ buffer. It will also recognize item context in multiline items." 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 @@ -9018,6 +9375,7 @@ buffer. It will also recognize item context in multiline items." org-shifttab org-shifttab org-shiftup + org-show-children org-show-subtree org-sort org-up-element @@ -9025,8 +9383,7 @@ buffer. It will also recognize item context in multiline items." outline-next-visible-heading outline-previous-visible-heading outline-promote - outline-up-heading - show-children)) + outline-up-heading)) (let ((f (or (car-safe cell) cell)) (disable-when-heading-prefix (cdr-safe cell))) (when (fboundp f) @@ -9045,15 +9402,15 @@ buffer. It will also recognize item context in multiline items." (regexp-quote (cdr rep)) (car rep) (key-description binding))))) - (pushnew binding new-bindings :test 'equal))) + (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)) - (condition-case nil - (org-defkey orgstruct-mode-map - binding - (orgstruct-make-binding f binding disable-when-heading-prefix)) - (error nil))))))))) + (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) @@ -9152,9 +9509,9 @@ definitions." ;; normalize contexts (mapcar (lambda(c) (cond ((listp (cadr c)) - (list (car c) (car c) (cadr c))) + (list (car c) (car c) (nth 1 c))) ((string= "" (cadr c)) - (list (car c) (car c) (caddr c))) + (list (car c) (car c) (nth 2 c))) (t c))) contexts)) (a alist) r s) @@ -9168,7 +9525,7 @@ definitions." (setq vrules (org-contextualize-validate-key (car c) contexts))) (mapc (lambda (vr) - (when (not (equal (car vr) (cadr vr))) + (unless (equal (car vr) (cadr vr)) (setq repl vr))) vrules) (if (not repl) (push c r) @@ -9185,39 +9542,37 @@ definitions." (delete-dups (mapcar (lambda (x) (let ((tpl (car x))) - (when (not (delq - nil - (mapcar (lambda (y) - (equal y tpl)) - s))) + (unless (delq + nil + (mapcar (lambda (y) + (equal y tpl)) + s)) x))) (reverse r)))))) (defun org-contextualize-validate-key (key contexts) "Check CONTEXTS for agenda or capture KEY." - (let (rr res) + (let (res) (dolist (r contexts) - (mapc - (lambda (rr) - (when - (and (equal key (car r)) - (if (functionp rr) (funcall rr) - (or (and (eq (car rr) 'in-file) - (buffer-file-name) - (string-match (cdr rr) (buffer-file-name))) - (and (eq (car rr) 'in-mode) - (string-match (cdr rr) (symbol-name major-mode))) - (and (eq (car rr) 'in-buffer) - (string-match (cdr rr) (buffer-name))) - (when (and (eq (car rr) 'not-in-file) - (buffer-file-name)) - (not (string-match (cdr rr) (buffer-file-name)))) - (when (eq (car rr) 'not-in-mode) - (not (string-match (cdr rr) (symbol-name major-mode)))) - (when (eq (car rr) 'not-in-buffer) - (not (string-match (cdr rr) (buffer-name))))))) - (push r res))) - (car (last r)))) + (dolist (rr (car (last r))) + (when + (and (equal key (car r)) + (if (functionp rr) (funcall rr) + (or (and (eq (car rr) 'in-file) + (buffer-file-name) + (string-match (cdr rr) (buffer-file-name))) + (and (eq (car rr) 'in-mode) + (string-match (cdr rr) (symbol-name major-mode))) + (and (eq (car rr) 'in-buffer) + (string-match (cdr rr) (buffer-name))) + (when (and (eq (car rr) 'not-in-file) + (buffer-file-name)) + (not (string-match (cdr rr) (buffer-file-name)))) + (when (eq (car rr) 'not-in-mode) + (not (string-match (cdr rr) (symbol-name major-mode)))) + (when (eq (car rr) 'not-in-buffer) + (not (string-match (cdr rr) (buffer-name))))))) + (push r res)))) (delete-dups (delq nil res)))) (defun org-context-p (&rest contexts) @@ -9235,45 +9590,47 @@ Possible values in the list of contexts are `table', `headline', and `item'." (org-in-item-p))) (goto-char pos)))) +(defconst org-unique-local-variables + '(org-element--cache + org-element--cache-objects + org-element--cache-sync-keys + org-element--cache-sync-requests + org-element--cache-sync-timer) + "List of local variables that cannot be transferred to another buffer.") + (defun org-get-local-variables () "Return a list of all local variables in an Org mode buffer." - (let (varlist) - (with-current-buffer (get-buffer-create "*Org tmp*") - (erase-buffer) - (org-mode) - (setq varlist (buffer-local-variables))) - (kill-buffer "*Org tmp*") - (delq nil - (mapcar - (lambda (x) - (setq x - (if (symbolp x) - (list x) - (list (car x) (cdr x)))) - (if (and (not (get (car x) 'org-state)) - (string-match - "^\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|auto-fill\\|normal-auto-fill\\|fill-paragraph\\|indent-\\)" - (symbol-name (car x)))) - x nil)) - varlist)))) + (delq nil + (mapcar + (lambda (x) + (let* ((binding (if (symbolp x) (list x) (list (car x) (cdr x)))) + (name (car binding))) + (and (not (get name 'org-state)) + (not (memq name org-unique-local-variables)) + (string-match-p + "\\`\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|\ +auto-fill\\|normal-auto-fill\\|fill-paragraph\\|indent-\\)" + (symbol-name name)) + binding))) + (with-temp-buffer + (org-mode) + (buffer-local-variables))))) (defun org-clone-local-variables (from-buffer &optional regexp) "Clone local variables from FROM-BUFFER. Optional argument REGEXP selects variables to clone." - (mapc - (lambda (pair) - (and (symbolp (car pair)) - (or (null regexp) - (string-match regexp (symbol-name (car pair)))) - (set (make-local-variable (car pair)) - (cdr pair)))) - (buffer-local-variables from-buffer))) + (dolist (pair (buffer-local-variables from-buffer)) + (pcase pair + (`(,name . ,value) ;ignore unbound variables + (when (and (not (memq name org-unique-local-variables)) + (or (null regexp) (string-match-p regexp (symbol-name name)))) + (set (make-local-variable name) value)))))) ;;;###autoload (defun org-run-like-in-org-mode (cmd) - "Run a command, pretending that the current buffer is in Org-mode. + "Run a command, pretending that the current buffer is in Org mode. This will temporarily bind local variables that are typically bound in -Org-mode to the values they have in Org-mode, and then interactively +Org mode to the values they have in Org mode, and then interactively call CMD." (org-load-modules-maybe) (unless org-local-vars @@ -9287,67 +9644,119 @@ call CMD." (eval `(let ,binds (call-interactively (quote ,cmd)))))) -;;;; Archiving - (defun org-get-category (&optional pos force-refresh) "Get the category applying to position POS." (save-match-data - (if force-refresh (org-refresh-category-properties)) + (when force-refresh (org-refresh-category-properties)) (let ((pos (or pos (point)))) (or (get-text-property pos 'org-category) (progn (org-refresh-category-properties) (get-text-property pos 'org-category)))))) -(defun org-refresh-category-properties () - "Refresh category text properties in the buffer." - (let ((case-fold-search t) - (inhibit-read-only t) - (def-cat (cond - ((null org-category) - (if buffer-file-name - (file-name-sans-extension - (file-name-nondirectory buffer-file-name)) - "???")) - ((symbolp org-category) (symbol-name org-category)) - (t org-category))) - beg end cat pos optionp) - (org-with-silent-modifications - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (put-text-property (point) (point-max) 'org-category def-cat) - (while (re-search-forward - "^\\(#\\+CATEGORY:\\|[ \t]*:CATEGORY:\\)\\(.*\\)" nil t) - (setq pos (match-end 0) - optionp (equal (char-after (match-beginning 0)) ?#) - cat (org-trim (match-string 2))) - (if optionp - (setq beg (point-at-bol) end (point-max)) - (org-back-to-heading t) - (setq beg (point) end (org-end-of-subtree t t))) - (put-text-property beg end 'org-category cat) - (put-text-property beg end 'org-category-position beg) - (goto-char pos))))))) +;;; Refresh properties (defun org-refresh-properties (dprop tprop) "Refresh buffer text properties. -DPROP is the drawer property and TPROP is the corresponding text -property to set." - (let ((case-fold-search t) - (inhibit-read-only t) p) +DPROP is the drawer property and TPROP is either the +corresponding text property to set, or an alist with each element +being a text property (as a symbol) and a function to apply to +the value of the drawer property." + (let* ((case-fold-search t) + (inhibit-read-only t) + (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 - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward (concat "^[ \t]*:" dprop ": +\\(.*\\)[ \t]*$") nil t) - (setq p (org-match-string-no-properties 1)) - (save-excursion - (org-back-to-heading t) - (put-text-property - (point-at-bol) (or (outline-next-heading) (point-max)) tprop p)))))))) + (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. +The refresh happens only for the current headline, or the whole +sub-tree if optional argument INHERIT is non-nil." + (unless (org-before-first-heading-p) + (save-excursion + (org-back-to-heading t) + (let ((start (point)) + (end (save-excursion + (if inherit (org-end-of-subtree t t) + (or (outline-next-heading) (point-max)))))) + (if (symbolp tprop) + ;; TPROP is a text property symbol. + (put-text-property start end tprop p) + ;; TPROP is an alist with (property . function) elements. + (pcase-dolist (`(,prop . ,f) tprop) + (put-text-property start end prop (funcall f p)))))))) +(defun org-refresh-category-properties () + "Refresh category text properties in the buffer." + (let ((case-fold-search t) + (inhibit-read-only t) + (default-category + (cond ((null org-category) + (if buffer-file-name + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + "???")) + ((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))))))))) + +(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))))))) + +(defun org-refresh-effort-properties () + "Refresh effort properties" + (org-refresh-properties + org-effort-property + '((effort . identity) + (effort-minutes . org-duration-string-to-minutes)))) ;;;; Link Stuff @@ -9387,78 +9796,54 @@ property to set." (defvar org-store-link-plist nil "Plist with info about the most recently link created with `org-store-link'.") -(defvar org-link-protocols nil - "Link protocols added to Org-mode using `org-add-link-type'.") +(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'. -(defvar org-store-link-functions nil - "List of functions that are called to create and store a link. 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 a calling -`org-store-link-props' with a list of properties and values. -Special properties are: +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. + 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.") - -(defun org-add-link-type (type &optional follow export) - "Add TYPE to the list of `org-link-types'. -Re-compute all regular expressions depending on `org-link-types' - -FOLLOW and EXPORT are two functions. - -FOLLOW should take the link path as the single argument and do whatever -is necessary to follow the link, for example find a file or display -a mail message. - -EXPORT should format the link path for export to one of the export formats. -It should be a function accepting three arguments: - - path the path of the link, the text after the prefix (like \"http:\") - desc the description of the link, if any, or a description added by - org-export-normalize-links if there is none - format the export format, a symbol like `html' or `latex' or `ascii'.. - -The function may use the FORMAT information to return different values -depending on the format. The return value will be put literally into -the exported file. If the return value is nil, this means Org should -do what it normally does with links which do not have EXPORT defined. - -Org-mode has a built-in default for exporting links. If you are happy with -this default, there is no need to define an export function for the link -type. For a simple example of an export function, see `org-bbdb.el'." - (add-to-list 'org-link-types type t) - (org-make-link-regexps) - (if (assoc type org-link-protocols) - (setcdr (assoc type org-link-protocols) (list follow export)) - (push (list type follow export) org-link-protocols))) +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) - "\\<org-mode-map>Store an org-link to the current location. + "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]. +into an Org buffer with `org-insert-link' (`\\[org-insert-link]'). -For some link types, a prefix arg is interpreted. -For links to Usenet articles, arg negates `org-gnus-prefer-web-links'. -For file links, arg negates `org-context-in-file-links'. +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 double prefix arg force skipping storing functions that are not -part of Org's core. +A `\\[universal-argument] \\[universal-argument]' prefix ARG forces \ +skipping storing functions that are not +part of Org core. -A triple prefix arg force storing a link for each line in the +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) @@ -9473,111 +9858,111 @@ active region." (call-interactively 'org-store-link)) (move-beginning-of-line 2) (set-mark (point))))) - (org-with-limited-levels - (setq org-store-link-plist nil) - (let (link cpltxt desc description search - txt custom-id agenda-link sfuns sfunsn) - (cond + (setq org-store-link-plist nil) + (let (link cpltxt desc description search + txt custom-id agenda-link sfuns sfunsn) + (cond - ;; Store a link using an external link type - ((and (not (equal arg '(16))) - (setq sfuns - (delq - nil (mapcar (lambda (f) - (let (fs) (if (funcall f) (push f fs)))) - org-store-link-functions)) - sfunsn (mapcar (lambda (fu) (symbol-name (car fu))) sfuns)) - (or (and (cdr sfuns) - (funcall (intern - (completing-read - "Which function for creating the link? " - sfunsn nil t (car sfunsn))))) - (funcall (caar sfuns))) - (setq link (plist-get org-store-link-plist :link) - desc (or (plist-get org-store-link-plist - :description) - link)))) - - ;; Store a link from a source code buffer - ((org-src-edit-buffer-p) - (let (label gc) - (while (or (not label) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (re-search-forward - (regexp-quote (format org-coderef-label-format label)) - nil t)))) - (when label (message "Label exists already") (sit-for 2)) - (setq label (read-string "Code line label: " label))) - (end-of-line 1) - (setq link (format org-coderef-label-format label)) - (setq gc (- 79 (length link))) - (if (< (current-column) gc) (org-move-to-column gc t) (insert " ")) - (insert link) - (setq link (concat "(" label ")") desc nil))) - - ;; We are in the agenda, link to referenced location - ((equal (org-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 (org-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) - (apply 'encode-time - (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) - nil nil nil)))) - (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 - ((eq major-mode '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)) + ;; Store a link using an external link type + ((and (not (equal arg '(16))) + (setq sfuns + (delq + nil (mapcar (lambda (f) + (let (fs) (if (funcall f) (push f fs)))) + (org-store-link-functions))) + sfunsn (mapcar (lambda (fu) (symbol-name (car fu))) sfuns)) + (or (and (cdr sfuns) + (funcall (intern + (completing-read + "Which function for creating the link? " + sfunsn nil t (car sfunsn))))) + (funcall (caar sfuns))) + (setq link (plist-get org-store-link-plist :link) + 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) + (apply 'encode-time + (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) + nil nil nil)))) + (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 @@ -9590,7 +9975,7 @@ active region." link cpltxt)) ((and (featurep 'org-id) (or (eq org-id-link-to-org-use-id t) - (and (org-called-interactively-p 'any) + (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) @@ -9613,15 +9998,13 @@ active region." (abbreviate-file-name (buffer-file-name (buffer-base-buffer))))) ;; Add a context search string - (when (org-xor org-context-in-file-links arg) - (let* ((ee (org-element-at-point)) - (et (org-element-type ee)) - (ev (plist-get (cadr ee) :value)) - (ek (plist-get (cadr ee) :key)) - (eok (and (stringp ek) (string-match "name" ek)))) + (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) - ((and (eq et 'keyword) eok) ev) + (name) ((org-region-active-p) (buffer-substring (region-beginning) (region-end))))) (when (or (null txt) (string-match "\\S-" txt)) @@ -9630,74 +10013,80 @@ active region." (condition-case nil (org-make-org-heading-search-string txt) (error ""))) - desc (or (and (eq et 'keyword) eok ev) + desc (or name (nth 4 (ignore-errors (org-heading-components))) "NONE"))))) - (if (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 arg) - (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)) - - ((org-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 - (if (consp link) (setq cpltxt (car link) link (cdr link))) - (setq link (or link cpltxt) - desc (or desc cpltxt)) - (cond ((equal desc "NONE") (setq desc nil)) - ((and desc (string-match org-bracket-link-analytic-regexp desc)) - (let ((d0 (match-string 3 desc)) - (p0 (match-string 5 desc))) - (setq desc - (replace-regexp-in-string - org-bracket-link-regexp - (concat (or p0 d0) - (if (equal (length (match-string 0 desc)) - (length desc)) "*" "")) desc))))) - - ;; Return the link - (if (not (and (or (org-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)))))) + (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, extract names and addresses." - (let (x adr) - (when (setq x (plist-get plist :from)) - (setq adr (mail-extract-address-components x)) - (setq plist (plist-put plist :fromname (car adr))) - (setq plist (plist-put plist :fromaddress (nth 1 adr)))) - (when (setq x (plist-get plist :to)) - (setq adr (mail-extract-address-components x)) - (setq plist (plist-put plist :toname (car adr))) - (setq plist (plist-put plist :toaddress (nth 1 adr))))) + "Store link properties, extract 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) @@ -9763,45 +10152,34 @@ according to FMT (default from `org-email-link-description-format')." (defun org-make-link-string (link &optional description) "Make a link with brackets, consisting of LINK and DESCRIPTION." - (unless (string-match "\\S-" link) - (error "Empty link")) - (when (and description - (stringp description) - (not (string-match "\\S-" description))) - (setq description nil)) - (when (stringp description) - ;; Remove brackets from the description, they are fatal. - (while (string-match "\\[" description) - (setq description (replace-match "{" t t description))) - (while (string-match "\\]" description) - (setq description (replace-match "}" t t description)))) - (when (equal link description) - ;; No description needed, it is identical - (setq description nil)) - (when (and (not description) - (not (string-match (org-image-file-name-regexp) link)) - (not (equal link (org-link-escape link)))) - (setq description (org-extract-attributes link))) - (setq link - (cond ((string-match (org-image-file-name-regexp) link) link) - ((string-match org-link-types-re link) - (concat (match-string 1 link) - (org-link-escape (substring link (match-end 1))))) - (t (org-link-escape link)))) - (concat "[[" link "]" - (if description (concat "[" 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))))) + ;; For readability, url-encode internal links only + ;; when absolutely needed (i.e, when they contain + ;; square brackets). File links however, are + ;; encoded since, e.g., spaces are significant. + ((or (file-name-absolute-p link) + (string-match-p "\\`\\.\\.?/\\|[][]" link)) + (org-link-escape link)) + (t link))) + (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) "")))) (defconst org-link-escape-chars - '(?\ ?\[ ?\] ?\; ?\= ?\+) - "List of characters that should be escaped in link. + ;;%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.") -(defconst org-link-escape-chars-browser - '(?\ ?\") - "List of escapes for characters that are problematic in links. -This is the list that is used before handing over to the browser.") - (defun org-link-escape (text &optional table merge) "Return percent escaped representation of TEXT. TEXT is a string with the text to escape. @@ -9809,35 +10187,29 @@ 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'." - (cond - ((and table merge) - (mapc (lambda (defchr) - (unless (member defchr table) - (setq table (cons defchr table)))) org-link-escape-chars)) - ((null table) - (setq table org-link-escape-chars))) - (mapconcat - (lambda (char) - (if (or (member char table) - (and (or (< char 32) (= char 37) (> char 126)) - org-url-hexify-p)) - (mapconcat (lambda (sequence-element) - (format "%%%.2X" sequence-element)) - (or (encode-coding-char char 'utf-8) - (error "Unable to percent escape character: %s" - (char-to-string char))) "") - (char-to-string char))) text "")) + (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 strings as returned from the JavaScript function -encodeURIComponent. E.g. `%C3%B6' is the german o-Umlaut." - (unless (and (null str) (string= "" str)) - (let ((pos 0) (case-fold-search t) unhexed) - (while (setq pos (string-match "\\(%[0-9a-f][0-9a-f]\\)+" str pos)) - (setq unhexed (org-link-unescape-compound (match-string 0 str))) - (setq str (replace-match unhexed t t str)) - (setq pos (+ pos (length unhexed)))))) - 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. @@ -9860,18 +10232,17 @@ Note: this function also decodes single byte encodings like ((>= val 192) (cons 2 192)) (t (cons 0 0))) (cons 6 128)))) - (if (>= val 192) (setq eat (car shift-xor))) + (when (>= val 192) (setq eat (car shift-xor))) (setq val (logxor val (cdr shift-xor))) (setq sum (+ (lsh sum (car shift-xor)) val)) - (if (> eat 0) (setq eat (- eat 1))) + (when (> eat 0) (setq eat (- eat 1))) (cond ((= 0 eat) ;multi byte - (setq ret (concat ret (org-char-to-string sum))) + (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)))) - )) ;; end (while bytes - ret ))) + (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." @@ -9901,28 +10272,47 @@ Note: this function also decodes single byte encodings like (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." +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-mode syntax." + "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 (&optional keep) - "Insert all links in `org-stored-links'." +(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 ((links (copy-sequence org-stored-links)) l) - (while (setq l (if keep (pop links) (pop org-stored-links))) - (insert "- ") - (org-insert-link nil (car l) (or (cadr l) "<no description>")) - (insert "\n")))) + (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'." @@ -9946,73 +10336,73 @@ This command can be called in any mode to insert a link in Org-mode syntax." (put-text-property 0 (length l) 'face 'font-lock-comment-face l)) (delq nil (append a b))))) -(defvar org-link-links-in-this-file nil) +(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 like -http or ftp in use. +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. +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. +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 +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 two \\[universal-argument] prefixes, enforce an absolute path even if the file is in +With a `\\[universal-argument] \\[universal-argument]' prefix, enforce an \ +absolute path even if the file is in the current directory or below. -With three \\[universal-argument] prefixes, negate the meaning of -`org-keep-stored-link-after-insertion'. +A `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \ +prefix negates `org-keep-stored-link-after-insertion'. 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. -If the LINK-LOCATION parameter is non-nil, this value will be -used as the link location instead of reading one interactively. +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." +If the DEFAULT-DESCRIPTION parameter is non-nil, this value will be used +as the default description." (interactive "P") (let* ((wcf (current-window-configuration)) (origbuf (current-buffer)) - (region (if (org-region-active-p) - (buffer-substring (region-beginning) (region-end)))) + (region (when (org-region-active-p) + (buffer-substring (region-beginning) (region-end)))) (remove (and region (list (region-beginning) (region-end)))) (desc region) - tmphist ; byte-compile incorrectly complains about this (link link-location) (abbrevs org-link-abbrev-alist-local) - entry file all-prefixes auto-desc) + entry all-prefixes auto-desc) (cond - (link-location) ; specified by arg, just use it. + (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 (if (match-end 3) (org-match-string-no-properties 3))) + (setq desc (when (match-end 3) (match-string-no-properties 3))) (setq link (read-string "Link: " (org-link-unescape - (org-match-string-no-properties 1))))) + (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-remove-angle-brackets (match-string 0))))) + (org-unbracket-string "<" ">" (match-string 0))))) ((member complete-file '((4) (16))) ;; Completing read for file names. (setq link (org-file-complete-link complete-file))) @@ -10035,92 +10425,91 @@ Use TAB to complete link prefixes, then RET for type-specific completion support (unless (pos-visible-in-window-p (point-max)) (org-fit-window-to-buffer)) (and (window-live-p cw) (select-window cw))) - ;; Fake a link history, containing the stored links. - (setq tmphist (append (mapcar 'car org-stored-links) - org-insert-link-history)) (setq all-prefixes (append (mapcar 'car abbrevs) (mapcar 'car org-link-abbrev-alist) - org-link-types)) + (org-link-types))) (unwind-protect - (progn + ;; 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)) + (mapcar (lambda (x) (concat x ":")) all-prefixes) + (mapcar #'car org-stored-links)) nil nil nil - 'tmphist + 'org--links-history (caar org-stored-links))) - (if (not (string-match "\\S-" link)) - (user-error "No link selected")) - (mapc (lambda(l) - (when (equal link (cadr l)) (setq link (car l) auto-desc t))) - org-stored-links) - (if (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))))) + (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))))) - (if (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 (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))) - (if (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-remove-angle-brackets link))) + (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 - (string-match "^file:\\(.+?\\)::\\(.+\\)" link)) - (let* ((path (match-string 1 link)) - (case-fold-search nil) - (search (match-string 2 link))) + (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 - (if (equal (file-truename buffer-file-name) (file-truename path)) - ;; We are linking to this same file, with a search option - (setq link search))))) + (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 - (when (string-match "^\\(file:\\|docview:\\)\\(.*\\)" link) - (let* ((type (match-string 1 link)) - (path (match-string 2 link)) - (origpath path) - (case-fold-search nil)) - (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)) - (if (equal desc origpath) - (setq desc path)))) + (let ((case-fold-search nil)) + (when (string-match "\\`\\(file\\|docview\\):" link) + (let* ((type (match-string-no-properties 0 link)) + (path (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)) + (when (equal desc origpath) + (setq desc path))))) (if org-make-link-description-function (setq desc @@ -10135,49 +10524,36 @@ Use TAB to complete link prefixes, then RET for type-specific completion support (read-string "Description: " desc))))) (unless (string-match "\\S-" desc) (setq desc nil)) - (if remove (apply 'delete-region remove)) - (insert (org-make-link-string link desc)))) + (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 (intern (concat "org-" type "-complete-link")))) + (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 link) - (setq file (org-iread-file-name "File: ")) - (let ((pwd (file-name-as-directory (expand-file-name "."))) - (pwd1 (file-name-as-directory (abbreviate-file-name - (expand-file-name "."))))) - (cond - ((equal arg '(16)) - (setq link (concat - "file:" - (abbreviate-file-name (expand-file-name file))))) - ((string-match (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) - (setq link (concat "file:" (match-string 1 file)))) - ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") - (expand-file-name file)) - (setq link (concat - "file:" (match-string 1 (expand-file-name file))))) - (t (setq link (concat "file:" file))))) - link)) - -(defun org-iread-file-name (&rest args) - "Read-file-name using `ido-mode' speedup if available. -ARGS are arguments that may be passed to `ido-read-file-name' or `read-file-name'. -See `read-file-name' for a description of parameters." - (org-without-partial-completion - (if (and org-completion-use-ido - (fboundp 'ido-read-file-name) - (boundp 'ido-mode) ido-mode - (listp (second args))) - (let ((ido-enter-matching-directory nil)) - (apply 'ido-read-file-name args)) - (apply 'read-file-name args)))) + (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." @@ -10186,58 +10562,9 @@ See `read-file-name' for a description of parameters." (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 'org-icompleting-read args))) - -(defun org-completing-read-no-i (&rest args) - (let (org-completion-use-ido org-completion-use-iswitchb) - (apply 'org-completing-read args))) - -(defun org-iswitchb-completing-read (prompt choices &rest args) - "Use iswitch as a completing-read replacement to choose from choices. -PROMPT is a string to prompt with. CHOICES is a list of strings to choose -from." - (let* ((iswitchb-use-virtual-buffers nil) - (iswitchb-make-buflist-hook - (lambda () - (setq iswitchb-temp-buflist choices)))) - (iswitchb-read-buffer prompt))) - -(defun org-icompleting-read (&rest args) - "Completing-read using `ido-mode' or `iswitchb' speedups if available." - (org-without-partial-completion - (if (and org-completion-use-ido - (fboundp 'ido-completing-read) - (boundp 'ido-mode) ido-mode - (listp (second args))) - (let ((ido-enter-matching-directory nil)) - (apply 'ido-completing-read (concat (car args)) - (if (consp (car (nth 1 args))) - (mapcar 'car (nth 1 args)) - (nth 1 args)) - (cddr args))) - (if (and org-completion-use-iswitchb - (boundp 'iswitchb-mode) iswitchb-mode - (listp (second args))) - (apply 'org-iswitchb-completing-read (concat (car args)) - (if (consp (car (nth 1 args))) - (mapcar 'car (nth 1 args)) - (nth 1 args)) - (cddr args)) - (apply 'completing-read args))))) - -(defun org-extract-attributes (s) - "Extract the attributes cookie from a string and set as text property." - (let (a attr (start 0) key value) - (save-match-data - (when (string-match "{{\\([^}]+\\)}}$" s) - (setq a (match-string 1 s) s (substring s 0 (match-beginning 0))) - (while (string-match "\\([a-zA-Z]+\\)=\"\\([^\"]*\\)\"" a start) - (setq key (match-string 1 a) value (match-string 2 a) - start (match-end 0) - attr (plist-put attr (intern key) value)))) - (org-add-props s nil 'org-attr attr)) - s)) + (org-defkey minibuffer-local-completion-map (kbd "C-c !") + 'org-time-stamp-inactive) + (apply #'completing-read args))) ;;; Opening/following a link @@ -10257,8 +10584,8 @@ 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-mode can continue with other options -like exact and fuzzy text search.") +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. @@ -10270,7 +10597,7 @@ If the link is in hidden text, expose it." (setq org-link-search-failed nil) (let* ((pos (point)) (ct (org-context)) - (a (assoc :link ct)) + (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) @@ -10279,7 +10606,7 @@ If the link is in hidden text, expose it." (if (funcall srch-fun org-any-link-re nil t) (progn (goto-char (match-beginning 0)) - (if (outline-invisible-p) (org-show-context))) + (when (org-invisible-p) (org-show-context))) (goto-char pos) (setq org-link-search-failed t) (message "No further link found")))) @@ -10292,14 +10619,9 @@ If the link is in hidden text, expose it." (defun org-translate-link (s) "Translate a link string if a translation function has been defined." - (if (and org-link-translation-function - (fboundp org-link-translation-function) - (string-match "\\([a-zA-Z0-9]+\\):\\(.*\\)" s)) - (progn - (setq s (funcall org-link-translation-function - (match-string 1 s) (match-string 2 s))) - (concat (car s) ":" (cdr s))) - s)) + (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. @@ -10319,7 +10641,7 @@ This is still an experimental function, your mileage may vary." ;; 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-remove-angle-brackets (match-string 2 path)))))) + (org-unbracket-string "<" ">" (match-string 2 path)))))) (cons type path)) (defun org-find-file-at-mouse (ev) @@ -10333,28 +10655,32 @@ This is still an experimental function, your mileage may vary." See the docstring of `org-open-file' for details." (interactive "e") (mouse-set-point ev) - (if (eq major-mode 'org-agenda-mode) - (org-agenda-copy-local-variable 'org-link-abbrev-alist-local)) + (when (eq major-mode 'org-agenda-mode) + (org-agenda-copy-local-variable 'org-link-abbrev-alist-local)) (org-open-at-point)) (defvar org-window-config-before-follow-link nil "The window configuration before following a link. This is saved in case the need arises to restore it.") -(defvar org-open-link-marker (make-marker) - "Marker pointing to the location where `org-open-at-point' was called.") - ;;;###autoload (defun org-open-at-point-global () - "Follow a link like Org-mode does. -This command can be called in any mode to follow a link that has -Org-mode syntax." + "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) - (org-run-like-in-org-mode 'org-open-at-point)) + (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")))) ;;;###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." + "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 @@ -10375,267 +10701,240 @@ 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) ;; dynamically scoped -(defvar clean-buffer-list-kill-buffer-names) ; Defined in midnight.el +(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) - "Open link at or after point. -If there is no link at point, this function will search forward up to -the end of the current line. -Normally, files will be opened by an appropriate application. If the -optional prefix argument ARG is non-nil, Emacs will visit the file. -With a double prefix argument, try to open outside of Emacs, in the -application the system uses for this file type." - (interactive "P") - ;; if in a code block, then open the block's results - (unless (call-interactively #'org-babel-open-src-block-result) - (org-load-modules-maybe) - (move-marker org-open-link-marker (point)) - (setq org-window-config-before-follow-link (current-window-configuration)) - (org-remove-occur-highlights nil nil t) - (cond - ((and (org-at-heading-p) - (not (org-at-timestamp-p t)) - (not (org-in-regexp - (concat org-plain-link-re "\\|" - org-bracket-link-regexp "\\|" - org-angle-link-re "\\|" - "[ \t]:[^ \t\n]+:[ \t]*$"))) - (not (get-text-property (point) 'org-linked-text))) - (or (let* ((lkall (org-offer-links-in-entry (current-buffer) (point) arg)) - (lk0 (car lkall)) - (lk (if (stringp lk0) (list lk0) lk0)) - (lkend (cdr lkall))) - (mapcar (lambda(l) - (search-forward l nil lkend) - (goto-char (match-beginning 0)) - (org-open-at-point)) - lk)) - (progn (require 'org-attach) (org-attach-reveal 'if-exists)))) - ((run-hook-with-args-until-success 'org-open-at-point-functions)) - ((and (org-at-timestamp-p t) - (not (org-in-regexp org-bracket-link-regexp))) - (org-follow-timestamp-link)) - ((and (or (org-footnote-at-reference-p) (org-footnote-at-definition-p)) - (not (org-in-regexp org-any-link-re))) - (org-footnote-action)) - (t - (let (type path link line search (pos (point))) - (catch 'match - (save-excursion - (or (org-in-regexp org-plain-link-re) - (skip-chars-forward "^]\n\r")) - (when (org-in-regexp org-bracket-link-regexp 1) - (setq link (org-extract-attributes - (org-link-unescape (org-match-string-no-properties 1)))) - (while (string-match " *\n *" link) - (setq link (replace-match " " t t link))) - (setq link (org-link-expand-abbrev link)) - (cond - ((or (file-name-absolute-p link) - (string-match "^\\.\\.?/" link)) - (setq type "file" path link)) - ((string-match org-link-re-with-space3 link) - (setq type (match-string 1 link) path (match-string 2 link))) - ((string-match "^help:+\\(.+\\)" link) - (setq type "help" path (match-string 1 link))) - (t (setq type "thisfile" path link))) - (throw 'match t))) - - (when (get-text-property (point) 'org-linked-text) - (setq type "thisfile" - pos (if (get-text-property (1+ (point)) 'org-linked-text) - (1+ (point)) (point)) - path (buffer-substring - (or (previous-single-property-change pos 'org-linked-text) - (point-min)) - (or (next-single-property-change pos 'org-linked-text) - (point-max))) - ;; Ensure we will search for a <<<radio>>> link, not - ;; a simple reference like <<ref>> - path (concat "<" path)) - (throw 'match t)) + "Open link, timestamp, footnote or tags at point. - (save-excursion - (when (or (org-in-regexp org-angle-link-re) - (let ((match (org-in-regexp org-plain-link-re))) - ;; Check a plain link is not within a bracket link - (and match - (save-excursion - (save-match-data - (progn - (goto-char (car match)) - (not (org-in-regexp org-bracket-link-regexp))))))) - (let ((line_ending (save-excursion (end-of-line) (point)))) - ;; We are in a line before a plain or bracket link - (or (re-search-forward org-plain-link-re line_ending t) - (re-search-forward org-bracket-link-regexp line_ending t)))) - (setq type (match-string 1) - path (org-link-unescape (match-string 2))) - (throw 'match t))) - (save-excursion - (when (org-in-regexp (org-re "\\(:[[:alnum:]_@#%:]+\\):[ \t]*$")) - (setq type "tags" - path (match-string 1)) - (while (string-match ":" path) - (setq path (replace-match "+" t t path))) - (throw 'match t))) - (when (org-in-regexp "<\\([^><\n]+\\)>") - (setq type "tree-match" - path (match-string 1)) - (throw 'match t))) - (unless path - (user-error "No link found")) +When point is on a link, follow it. Normally, files will be +opened by an appropriate application. If the optional prefix +argument ARG is non-nil, Emacs will visit the file. With +a double prefix argument, try to open outside of Emacs, in the +application the system uses for this file type. - ;; switch back to reference buffer - ;; needed when if called in a temporary buffer through - ;; org-open-link-from-string - (with-current-buffer (or reference-buffer (current-buffer)) +When point is on a timestamp, open the agenda at the day +specified. - ;; Remove any trailing spaces in path - (if (string-match " +\\'" path) - (setq path (replace-match "" t t path))) - (if (and org-link-translation-function - (fboundp org-link-translation-function)) - ;; Check if we need to translate the link - (let ((tmp (funcall org-link-translation-function type path))) - (setq type (car tmp) path (cdr tmp)))) +When point is a footnote definition, move to the first reference +found. If it is on a reference, move to the associated +definition. - (cond +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. - ((assoc type org-link-protocols) - (funcall (nth 1 (assoc type org-link-protocols)) path)) - - ((equal type "help") - (let ((f-or-v (intern path))) - (cond ((fboundp f-or-v) - (describe-function f-or-v)) - ((boundp f-or-v) - (describe-variable f-or-v)) - (t (error "Not a known function or variable"))))) - - ((equal type "mailto") - (let ((cmd (car org-link-mailto-program)) - (args (cdr org-link-mailto-program)) args1 - (address path) (subject "") a) - (if (string-match "\\(.*\\)::\\(.*\\)" path) - (setq address (match-string 1 path) - subject (org-link-escape (match-string 2 path)))) - (while args - (cond - ((not (stringp (car args))) (push (pop args) args1)) - (t (setq a (pop args)) - (if (string-match "%a" a) - (setq a (replace-match address t t a))) - (if (string-match "%s" a) - (setq a (replace-match subject t t a))) - (push a args1)))) - (apply cmd (nreverse args1)))) - - ((member type '("http" "https" "ftp" "news")) - (browse-url - (concat type ":" - (if (org-string-match-p - (concat "[[:nonascii:]" - org-link-escape-chars-browser "]") - path) - (org-link-escape path org-link-escape-chars-browser) - path)))) - - ((string= type "doi") - (browse-url - (concat org-doi-server-url - (if (org-string-match-p - (concat "[[:nonascii:]" - org-link-escape-chars-browser "]") - path) - (org-link-escape path org-link-escape-chars-browser) - path)))) - - ((member type '("message")) - (browse-url (concat type ":" path))) - - ((string= type "tags") - (org-tags-view arg path)) - - ((string= type "tree-match") - (org-occur (concat "\\[" (regexp-quote path) "\\]"))) - - ((string= type "file") - (if (string-match "::\\([0-9]+\\)\\'" path) - (setq line (string-to-number (match-string 1 path)) - path (substring path 0 (match-beginning 0))) - (if (string-match "::\\(.+\\)\\'" path) - (setq search (match-string 1 path) - path (substring path 0 (match-beginning 0))))) - (if (string-match "[*?{]" (file-name-nondirectory path)) - (dired path) - (org-open-file path arg line search))) - - ((string= type "shell") - (let ((buf (generate-new-buffer "*Org Shell Output")) - (cmd path)) - (if (or (and (not (string= 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) - (if (featurep 'midnight) - (setq clean-buffer-list-kill-buffer-names - (cons buf clean-buffer-list-kill-buffer-names)))) - (error "Abort")))) - - ((string= type "elisp") - (let ((cmd path)) - (if (or (and (not (string= org-confirm-elisp-link-not-regexp "")) - (string-match 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 (equal (string-to-char cmd) ?\() - (eval (read cmd)) - (call-interactively (read cmd)))) - (error "Abort")))) - - ((and (string= type "thisfile") - (or (run-hook-with-args-until-success - 'org-open-link-functions path) - (and link - (string-match "^id:" link) - (or (featurep 'org-id) (require 'org-id)) - (progn - (funcall (nth 1 (assoc "id" org-link-protocols)) - (substring path 3)) - t))))) - - ((string= type "thisfile") - (if arg - (switch-to-buffer-other-window - (org-get-buffer-for-internal-link (current-buffer))) - (org-mark-ring-push)) - (let ((cmd `(org-link-search - ,path - ,(cond ((equal arg '(4)) ''occur) - ((equal arg '(16)) ''org-occur)) - ,pos))) - (condition-case nil (let ((org-link-search-inhibit-query t)) - (eval cmd)) - (error (progn (widen) (eval cmd)))))) - - (t (browse-url-at-point))))))) - (move-marker org-open-link-marker nil) - (run-hook-with-args 'org-follow-link-hook))) +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'. -(defsubst org-uniquify (list) - "Non-destructively remove duplicate elements from LIST." - (let ((res (copy-sequence list))) (delete-dups res))) +On top of syntactically correct links, this function will open +the link at point in comments or comment blocks and the first +link in a property drawer line." + (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 comment comment-block footnote-definition + footnote-reference headline inlinetask keyword link + node-property timestamp) + t)) + (type (org-element-type context)) + (value (org-element-property :value context))) + (cond + ((not context) (user-error "No link found")) + ;; Exception: open timestamps and links in properties + ;; drawers, keywords and comments. + ((memq type '(comment comment-block keyword node-property)) + (call-interactively #'org-open-at-point-global)) + ;; On a headline or an inlinetask, but not on a timestamp, + ;; a link, a footnote reference or on tags. + ((and (memq type '(headline inlinetask)) + ;; Not on tags. + (let ((case-fold-search nil)) + (save-excursion + (beginning-of-line) + (looking-at org-complex-heading-regexp)) + (or (not (match-beginning 5)) + (< (point) (match-beginning 5))))) + (let* ((data (org-offer-links-in-entry (current-buffer) (point) arg)) + (links (car data)) + (links-end (cdr data))) + (if links + (dolist (link (if (stringp links) (list links) links)) + (search-forward link nil links-end) + (goto-char (match-beginning 0)) + (org-open-at-point)) + (require 'org-attach) + (org-attach-reveal 'if-exists)))) + ;; 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)) + ;; On tags within a headline or an inlinetask. + ((and (memq type '(headline inlinetask)) + (let ((case-fold-search nil)) + (save-excursion (beginning-of-line) + (looking-at org-complex-heading-regexp)) + (and (match-beginning 5) + (>= (point) (match-beginning 5))))) + (org-tags-view arg (substring (match-string 5) 0 -1))) + ((eq type 'link) + ;; When link is located within the description of another + ;; link (e.g., an inline image), always open the parent + ;; link. + (let* ((link (let ((up (org-element-property :parent context))) + (if (eq (org-element-type up) 'link) up context))) + (type (org-element-property :type link)) + (path (org-link-unescape (org-element-property :path link)))) + ;; 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 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 + (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 link)) + (org-link-search + (if (member type '("custom-id" "coderef")) + (org-element-property :raw-link link) + 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)))))) + ;; On a footnote reference or at a footnote 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 behaviour 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)) + (t (user-error "No link found"))))) + (run-hook-with-args 'org-follow-link-hook))) (defun org-offer-links-in-entry (buffer marker &optional nth zero) "Offer links in the current entry and return the selected link. @@ -10644,65 +10943,57 @@ If NTH is an integer, return the NTH link found. If ZERO is a string, check also this string for a link, and if there is one, return it." (with-current-buffer buffer - (save-excursion - (save-restriction - (widen) - (goto-char marker) - (let ((re (concat "\\(" org-bracket-link-regexp "\\)\\|" - "\\(" org-angle-link-re "\\)\\|" - "\\(" org-plain-link-re "\\)")) - (cnt ?0) - (in-emacs (if (integerp nth) nil nth)) - have-zero end links link c) - (when (and (stringp zero) (string-match org-bracket-link-regexp 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 re end t) - (push (match-string 0) links)) - (setq links (org-uniquify (reverse links)))) - (cond - ((null links) - (message "No links")) - ((equal (length links) 1) - (setq link (car links))) - ((and (integerp nth) (>= (length links) (if have-zero (1+ nth) nth))) - (setq link (nth (if have-zero nth (1- nth)) links))) - (t ; we have to select a link - (save-excursion - (save-window-excursion - (delete-other-windows) - (with-output-to-temp-buffer "*Select Link*" - (mapc (lambda (l) - (if (not (string-match org-bracket-link-regexp l)) - (princ (format "[%c] %s\n" (incf cnt) - (org-remove-angle-brackets l))) - (if (match-end 3) - (princ (format "[%c] %s (%s)\n" (incf cnt) - (match-string 3 l) (match-string 1 l))) - (princ (format "[%c] %s\n" (incf cnt) - (match-string 1 l)))))) - links)) - (org-fit-window-to-buffer (get-buffer-window "*Select Link*")) - (message "Select link to open, RET to open all:") - (setq c (read-char-exclusive)) - (and (get-buffer "*Select Link*") (kill-buffer "*Select Link*")))) - (when (equal c ?q) (error "Abort")) - (if (equal c ?\C-m) - (setq link links) - (setq nth (- c ?0)) - (if have-zero (setq nth (1+ nth))) - (unless (and (integerp nth) (>= (length links) nth)) - (user-error "Invalid link selection")) - (setq link (nth (1- nth) links))))) - (cons link end)))))) - -;; Add special file links that specify the way of opening - -(org-add-link-type "file+sys" 'org-open-file-with-system) -(org-add-link-type "file+emacs" 'org-open-file-with-emacs) + (org-with-wide-buffer + (goto-char marker) + (let ((cnt ?0) + have-zero end links link c) + (when (and (stringp zero) (string-match org-bracket-link-regexp 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) + (push (match-string 0) links)) + (setq links (org-uniquify (reverse links)))) + (cond + ((null links) + (message "No links")) + ((equal (length links) 1) + (setq link (car links))) + ((and (integerp nth) (>= (length links) (if have-zero (1+ nth) nth))) + (setq link (nth (if have-zero nth (1- nth)) links))) + (t ; we have to select a link + (save-excursion + (save-window-excursion + (delete-other-windows) + (with-output-to-temp-buffer "*Select Link*" + (dolist (l links) + (cond + ((not (string-match org-bracket-link-regexp l)) + (princ (format "[%c] %s\n" (cl-incf cnt) + (org-unbracket-string "<" ">" l)))) + ((match-end 3) + (princ (format "[%c] %s (%s)\n" (cl-incf cnt) + (match-string 3 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*")) + (message "Select link to open, RET to open all:") + (setq c (read-char-exclusive)) + (and (get-buffer "*Select Link*") (kill-buffer "*Select Link*")))) + (when (equal c ?q) (user-error "Abort")) + (if (equal c ?\C-m) + (setq link links) + (setq nth (- c ?0)) + (when have-zero (setq nth (1+ nth))) + (unless (and (integerp nth) (>= (length links) nth)) + (user-error "Invalid link selection")) + (setq link (nth (1- nth) links))))) + (cons link end))))) + +;; TODO: These functions are deprecated since `org-open-at-point' +;; hard-codes behaviour 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)) @@ -10732,8 +11023,8 @@ 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-mode -buffer with \\[org-insert-link].") +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. @@ -10757,179 +11048,201 @@ the window configuration before `org-open-at-point' was called using: (set-window-configuration org-window-config-before-follow-link)") -(defun org-link-search (s &optional type avoid-pos stealth) - "Search for a link search option. -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. If AVOID-POS is given, ignore matches near that position. +(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 + (org-split-string target "[ \t\n]+") + "[ \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-hierarchy-above', `org-show-following-heading' and -`org-show-siblings' variables." - (let ((case-fold-search t) - (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " ")) - (markers (concat "\\(?:" (mapconcat (lambda (x) (regexp-quote (car x))) - (append '(("") (" ") ("\t") ("\n")) - org-emphasis-alist) - "\\|") "\\)")) - (pos (point)) - (pre nil) (post nil) - words re0 re1 re2 re3 re4_ re4 re5 re2a re2a_ reall) +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 - ;; First check if there are any special search functions + ;; Check if there are any special search functions. ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) - ;; Now try the builtin stuff - ((and (equal (string-to-char s0) ?#) - (> (length s0) 1) - (save-excursion - (goto-char (point-min)) - (and - (re-search-forward - (concat "^[ \t]*:CUSTOM_ID:[ \t]+" - (regexp-quote (substring s0 1)) "[ \t]*$") nil t) - (setq type 'dedicated - pos (match-beginning 0)))) - ;; There is an exact target for this - (goto-char pos) - (org-back-to-heading t))) - ((save-excursion + ((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)) - (and - (re-search-forward - (concat "<<" (regexp-quote s0) ">>") nil t) - (setq type 'dedicated - pos (match-beginning 0)))) - ;; There is an exact target for this - (goto-char pos)) - ((save-excursion - (goto-char (point-min)) - (and - (re-search-forward - (format "^[ \t]*#\\+NAME: %s" (regexp-quote s0)) nil t) - (setq type 'dedicated pos (match-beginning 0)))) - ;; Found an element with a matching #+name affiliated keyword. - (goto-char pos)) - ((and (string-match "^(\\(.*\\))$" s0) - (save-excursion + (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 (format "\\`%s[ \t]+" org-comment-string))) (goto-char (point-min)) - (and - (re-search-forward - (concat "[^[]" (regexp-quote - (format org-coderef-label-format - (match-string 1 s0)))) - nil t) - (setq type 'dedicated - pos (1+ (match-beginning 0)))))) - ;; There is a coderef target for this - (goto-char pos)) - ((string-match "^/\\(.*\\)/$" s) - ;; A regular expression - (cond - ((derived-mode-p 'org-mode) - (org-occur (match-string 1 s))) - (t (org-do-occur (match-string 1 s))))) - ((and (derived-mode-p 'org-mode) org-link-search-must-match-exact-headline) - (and (equal (string-to-char s) ?*) (setq s (substring s 1))) - (goto-char (point-min)) - (cond - ((let (case-fold-search) - (re-search-forward (format org-complex-heading-regexp-format - (regexp-quote s)) - nil t)) - ;; OK, found a match - (setq type 'dedicated) - (goto-char (match-beginning 0))) - ((and (not org-link-search-inhibit-query) - (eq org-link-search-must-match-exact-headline 'query-to-create) - (y-or-n-p "No match - create this as a new heading? ")) - (goto-char (point-max)) - (or (bolp) (newline)) - (insert "* " s "\n") - (beginning-of-line 0)) - (t - (goto-char pos) - (error "No match")))) - (t - ;; A normal search string - (when (equal (string-to-char s) ?*) - ;; Anchor on headlines, post may include tags. - (setq pre "^\\*+[ \t]+\\(?:\\sw+\\)?[ \t]*" - post (org-re "[ \t]*\\(?:[ \t]+:[[:alnum:]_@#%:+]:[ \t]*\\)?$") - s (substring s 1))) - (remove-text-properties - 0 (length s) - '(face nil mouse-face nil keymap nil fontified nil) s) - ;; Make a series of regular expressions to find a match - (setq words (org-split-string s "[ \n\r\t]+") - - re0 (concat "\\(<<" (regexp-quote s0) ">>\\)") - re2 (concat markers "\\(" (mapconcat 'downcase words "[ \t]+") - "\\)" markers) - re2a_ (concat "\\(" (mapconcat 'downcase words - "[ \t\r\n]+") "\\)[ \t\r\n]") - re2a (concat "[ \t\r\n]" re2a_) - re4_ (concat "\\(" (mapconcat 'downcase words - "[^a-zA-Z_\r\n]+") "\\)[^a-zA-Z_]") - re4 (concat "[^a-zA-Z_]" re4_) - - re1 (concat pre re2 post) - re3 (concat pre (if pre re4_ re4) post) - re5 (concat pre ".*" re4) - re2 (concat pre re2) - re2a (concat pre (if pre re2a_ re2a)) - re4 (concat pre (if pre re4_ re4)) - reall (concat "\\(" re0 "\\)\\|\\(" re1 "\\)\\|\\(" re2 - "\\)\\|\\(" re3 "\\)\\|\\(" re4 "\\)\\|\\(" - re5 "\\)")) - (cond - ((eq type 'org-occur) (org-occur reall)) - ((eq type 'occur) (org-do-occur (downcase reall) 'cleanup)) - (t (goto-char (point-min)) - (setq type 'fuzzy) - (if (or (and (org-search-not-self 1 re0 nil t) - (setq type 'dedicated)) - (org-search-not-self 1 re1 nil t) - (org-search-not-self 1 re2 nil t) - (org-search-not-self 1 re2a nil t) - (org-search-not-self 1 re3 nil t) - (org-search-not-self 1 re4 nil t) - (org-search-not-self 1 re5 nil t)) - (goto-char (match-beginning 1)) - (goto-char pos) - (error "No match")))))) - (and (derived-mode-p 'org-mode) - (not stealth) - (org-show-context 'link-search)) + (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))))) + (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-search-not-self (group &rest args) - "Execute `re-search-forward', but only accept matches that do not -enclose the position of `org-open-link-marker'." - (let ((m org-open-link-marker)) - (catch 'exit - (while (apply #'re-search-forward args) - (unless (get-text-property (match-end group) 'intangible) ; Emacs 21 - (goto-char (match-end group)) - (if (and (or (not (eq (marker-buffer m) (current-buffer))) - (> (match-beginning 0) (marker-position m)) - (< (match-end 0) (marker-position m))) - (save-match-data - (or (not (org-in-regexp - org-bracket-link-analytic-regexp 1)) - (not (match-end 4)) ; no description - (and (<= (match-beginning 4) (point)) - (>= (match-end 4) (point)))))) - (throw 'exit (point)))))))) - (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-match "(Clone)$" (buffer-name 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) @@ -10953,8 +11266,8 @@ to read." (goto-char (point-min)) (when (re-search-forward "match[a-z]+" nil t) (setq beg (match-end 0)) - (if (re-search-forward "^[ \t]*[0-9]+" nil t) - (setq end (1- (match-beginning 0))))) + (when (re-search-forward "^[ \t]*[0-9]+" nil t) + (setq end (1- (match-beginning 0))))) (and beg end (let ((inhibit-read-only t)) (delete-region beg end))) (goto-char (point-min)) (select-window cwin)))) @@ -10962,13 +11275,13 @@ to read." ;;; The mark ring for links jumps (defvar org-mark-ring nil - "Mark ring for positions before jumps in Org-mode.") + "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 -(loop for i from 1 to org-mark-ring-length do - (push (make-marker) org-mark-ring)) +(dotimes (_ org-mark-ring-length) + (push (make-marker) org-mark-ring)) (setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) org-mark-ring) @@ -10982,15 +11295,15 @@ to read." (or buffer (current-buffer))) (message "%s" (substitute-command-keys - "Position saved to mark ring, go back with \\[org-mark-ring-goto]."))) + "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. With prefix arg N, jump back that many stored positions. When called several times in succession, walk through the entire ring. -Org-mode commands jumping to a different position in the current file, -or to another Org-mode file, automatically push the old position -onto the ring." +Org mode commands jumping to a different position in the current file, +or to another Org file, automatically push the old position onto the ring." (interactive "p") (let (p m) (if (eq last-command this-command) @@ -10998,25 +11311,19 @@ onto the ring." (setq p org-mark-ring)) (setq org-mark-ring-last-goto p) (setq m (car p)) - (org-pop-to-buffer-same-window (marker-buffer m)) + (pop-to-buffer-same-window (marker-buffer m)) (goto-char m) - (if (or (outline-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) + (when (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) -(defun org-remove-angle-brackets (s) - (if (equal (substring s 0 1) "<") (setq s (substring s 1))) - (if (equal (substring s -1) ">") (setq s (substring s 0 -1))) - s) (defun org-add-angle-brackets (s) - (if (equal (substring s 0 1) "<") nil (setq s (concat "<" s))) - (if (equal (substring s -1) ">") nil (setq s (concat s ">"))) - s) -(defun org-remove-double-quotes (s) - (if (equal (substring s 0 1) "\"") (setq s (substring s 1))) - (if (equal (substring s -1) "\"") (setq s (substring s 0 -1))) + (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) +(defvar org-agenda-start-on-weekday) (defun org-follow-timestamp-link () "Open an agenda view for the time-stamp date/range at point." (cond @@ -11071,43 +11378,40 @@ If the file does not exist, an error is thrown." buffer-file-name (substitute-in-file-name (expand-file-name path)))) (file-apps (append org-file-apps (org-default-apps))) - (apps (org-remove-if + (apps (cl-remove-if 'org-file-apps-entry-match-against-dlink-p file-apps)) - (apps-dlink (org-remove-if-not + (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 (if remp nil (file-directory-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 file: link from the PATH, LINE and SEARCH args - (link (cond ((and (eq line nil) - (eq search nil)) - file) - (line - (concat file "::" (number-to-string line))) - (search - (concat file "::" search)))) + ;; 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)) (old-buffer (current-buffer)) (old-pos (point)) (old-mode major-mode) - ext cmd link-match-data) - (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile) - (setq ext (match-string 1 dfile)) - (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile) - (setq ext (match-string 1 dfile)))) + (ext + (and (string-match "\\`.*?\\.\\([a-zA-Z0-9]+\\(\\.gz\\)?\\)\\'" dfile) + (match-string 1 dfile))) + cmd link-match-data) (cond ((member in-emacs '((16) system)) - (setq cmd (cdr (assoc 'system apps)))) + (setq cmd (cdr (assq 'system apps)))) (in-emacs (setq cmd 'emacs)) (t - (setq cmd (or (and remp (cdr (assoc 'remote apps))) - (and dirp (cdr (assoc 'directory apps))) - ; first, try matching against apps-dlink - ; if we get a match here, store the match data for later + (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 @@ -11120,9 +11424,9 @@ If the file does not exist, an error is thrown." (assoc-default dfile (org-apps-regexp-alist apps a-m-a-p) 'string-match) (cdr (assoc ext apps)) - (cdr (assoc t apps)))))) + (cdr (assq t apps)))))) (when (eq cmd 'system) - (setq cmd (cdr (assoc 'system apps)))) + (setq cmd (cdr (assq 'system apps)))) (when (eq cmd 'default) (setq cmd (cdr (assoc t apps)))) (when (eq cmd 'mailcap) @@ -11133,21 +11437,20 @@ If the file does not exist, an error is thrown." (if (stringp command) (setq cmd command) (setq cmd 'emacs)))) - (if (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)) + (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))) - (while (string-match "%s" cmd) - (setq cmd (replace-match - (save-match-data - (shell-quote-argument - (convert-standard-filename file))) - 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 @@ -11169,17 +11472,33 @@ If the file does not exist, an error is thrown." (eq cmd 'emacs)) (funcall (cdr (assq 'file org-link-frame-setup)) file) (widen) - (if line (org-goto-line line) - (if search (org-link-search search)))) + (cond (line (org-goto-line line) + (when (derived-mode-p 'org-mode) (org-reveal))) + (search (org-link-search search)))) + ((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) - (let ((file (convert-standard-filename file))) - (save-match-data - (set-match-data link-match-data) - (eval 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))) - (and (derived-mode-p 'org-mode) (eq old-mode 'org-mode) - (or (not (equal old-buffer (current-buffer))) - (not (equal old-pos (point)))) + (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)))) (defun org-file-apps-entry-match-against-dlink-p (entry) @@ -11220,16 +11539,15 @@ be opened in Emacs." (append (delq nil (mapcar (lambda (x) - (if (not (stringp (car x))) - nil + (unless (not (stringp (car x))) (if (string-match "\\W" (car x)) x (cons (concat "\\." (car x) "\\'") (cdr x))))) list)) - (if add-auto-mode - (mapcar (lambda (x) (cons (car x) 'emacs)) auto-mode-alist)))) + (when add-auto-mode + (mapcar (lambda (x) (cons (car x) 'emacs)) auto-mode-alist)))) -(defvar ange-ftp-name-format) ; to silence the XEmacs compiler. +(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. @@ -11262,8 +11580,8 @@ on the system \"/user@host:\"." ((not (listp org-reverse-note-order)) nil) (t (catch 'exit (dolist (entry org-reverse-note-order) - (if (string-match (car entry) buffer-file-name) - (throw 'exit (cdr entry)))))))) + (when (string-match (car entry) buffer-file-name) + (throw 'exit (cdr entry)))))))) (defvar org-refile-target-table nil "The list of refile targets, created by `org-refile'.") @@ -11288,7 +11606,7 @@ on the system \"/user@host:\"." (defun org-refile-cache-clear () "Clear the refile cache and disable all the markers." - (mapc (lambda (m) (move-marker m nil)) org-refile-markers) + (dolist (m org-refile-markers) (move-marker m nil)) (setq org-refile-markers nil) (setq org-refile-cache nil) (message "Refile cache has been cleared")) @@ -11323,17 +11641,23 @@ on the system \"/user@host:\"." org-refile-cache)))) (and set (org-refile-cache-check-set set) set))))) -(defun org-refile-get-targets (&optional default-buffer excluded-entries) +(defvar org-outline-path-cache nil + "Alist between buffer positions and outline paths. +It value is an alist (POSITION . PATH) where POSITION is the +buffer position at the beginning of an entry and PATH is a list +of strings describing the outline path for that entry, in reverse +order.") + +(defun org-refile-get-targets (&optional default-buffer) "Produce a table with refile targets." (let ((case-fold-search nil) ;; otherwise org confuses "TODO" as a kw and "Todo" as a word (entries (or org-refile-targets '((nil . (:level . 1))))) - targets tgs txt re files desc descre fast-path-p level pos0) + targets tgs files desc descre) (message "Getting targets...") (with-current-buffer (or default-buffer (current-buffer)) (dolist (entry entries) (setq files (car entry) desc (cdr entry)) - (setq fast-path-p nil) (cond ((null files) (setq files (list (current-buffer)))) ((eq files 'org-agenda-files) @@ -11342,7 +11666,7 @@ on the system \"/user@host:\"." (setq files (funcall files))) ((and (symbolp files) (boundp files)) (setq files (symbol-value files)))) - (if (stringp files) (setq files (list files))) + (when (stringp files) (setq files (list files))) (cond ((eq (car desc) :tag) (setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":"))) @@ -11357,7 +11681,6 @@ on the system \"/user@host:\"." (cdr desc))) "\\}[ \t]"))) ((eq (car desc) :maxlevel) - (setq fast-path-p t) (setq descre (concat "^\\*\\{1," (number-to-string (if org-odd-levels-only (1- (* 2 (cdr desc))) @@ -11365,99 +11688,113 @@ on the system \"/user@host:\"." "\\}[ \t]"))) (t (error "Bad refiling target description %s" desc))) (dolist (f files) - (with-current-buffer - (if (bufferp f) f (org-get-agenda-file-buffer f)) + (with-current-buffer (if (bufferp f) f (org-get-agenda-file-buffer f)) (or (setq tgs (org-refile-cache-get (buffer-file-name) descre)) (progn - (if (bufferp f) (setq f (buffer-file-name - (buffer-base-buffer f)))) + (when (bufferp f) + (setq f (buffer-file-name (buffer-base-buffer f)))) (setq f (and f (expand-file-name f))) - (if (eq org-refile-use-outline-path 'file) - (push (list (file-name-nondirectory f) f nil nil) tgs)) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward descre nil t) - (goto-char (setq pos0 (point-at-bol))) - (catch 'next - (when org-refile-target-verify-function - (save-match-data - (or (funcall org-refile-target-verify-function) - (throw 'next t)))) - (when (and (looking-at org-complex-heading-regexp) - (not (member (match-string 4) excluded-entries)) - (match-string 4)) - (setq level (org-reduced-level - (- (match-end 1) (match-beginning 1))) - txt (org-link-display-format (match-string 4)) - txt (replace-regexp-in-string "\\( *[[0-9]+/?[0-9]*%?]\\)+$" "" txt) - re (format org-complex-heading-regexp-format - (regexp-quote (match-string 4)))) - (when org-refile-use-outline-path - (setq txt (mapconcat - 'org-protect-slash - (append - (if (eq org-refile-use-outline-path - 'file) - (list (file-name-nondirectory - (buffer-file-name - (buffer-base-buffer)))) - (if (eq org-refile-use-outline-path - 'full-file-path) - (list (buffer-file-name - (buffer-base-buffer))))) - (org-get-outline-path fast-path-p - level txt) - (list txt)) - "/"))) - (push (list txt f re (org-refile-marker (point))) - tgs))) - (when (= (point) pos0) - ;; verification function has not moved point - (goto-char (point-at-eol)))))))) + (when (eq org-refile-use-outline-path 'file) + (push (list (file-name-nondirectory f) f nil nil) tgs)) + (org-with-wide-buffer + (goto-char (point-min)) + (setq org-outline-path-cache nil) + (while (re-search-forward descre nil t) + (beginning-of-line) + (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp)) + (let ((begin (point)) + (heading (match-string-no-properties 4))) + (unless (or (and + org-refile-target-verify-function + (not + (funcall org-refile-target-verify-function))) + (not heading)) + (let ((re (format org-complex-heading-regexp-format + (regexp-quote heading))) + (target + (if (not org-refile-use-outline-path) heading + (mapconcat + #'org-protect-slash + (append + (pcase org-refile-use-outline-path + (`file (list (file-name-nondirectory + (buffer-file-name + (buffer-base-buffer))))) + (`full-file-path + (list (buffer-file-name + (buffer-base-buffer)))) + (_ nil)) + (org-get-outline-path t t)) + "/")))) + (push (list target f re (org-refile-marker (point))) + tgs))) + (when (= (point) begin) + ;; Verification function has not moved point. + (end-of-line))))))) (when org-refile-use-cache (org-refile-cache-put tgs (buffer-file-name) descre)) (setq targets (append tgs targets)))))) (message "Getting targets...done") - (nreverse targets))) + (delete-dups (nreverse targets)))) (defun org-protect-slash (s) - (while (string-match "/" s) - (setq s (replace-match "\\" t t s))) - s) - -(defvar org-olpa (make-vector 20 nil)) - -(defun org-get-outline-path (&optional fastp level heading) - "Return the outline path to the current entry, as a list. - -The parameters FASTP, LEVEL, and HEADING are for use by a scanner -routine which makes outline path derivations for an entire file, -avoiding backtracing. Refile target collection makes use of that." - (if fastp - (progn - (if (> level 19) - (error "Outline path failure, more than 19 levels")) - (loop for i from level upto 19 do - (aset org-olpa i nil)) - (prog1 - (delq nil (append org-olpa nil)) - (aset org-olpa level heading))) - (let (rtn case-fold-search) - (save-excursion - (save-restriction - (widen) - (while (org-up-heading-safe) - (when (looking-at org-complex-heading-regexp) - (push (org-trim - (replace-regexp-in-string - ;; Remove statistical/checkboxes cookies - "\\[[0-9]+%\\]\\|\\[[0-9]+/[0-9]+\\]" "" - (org-match-string-no-properties 4))) - rtn))) - rtn))))) + (replace-regexp-in-string "/" "\\/" s nil t)) + +(defun org--get-outline-path-1 (&optional use-cache) + "Return outline path to current headline. + +Outline path is a list of strings, in reverse order. When +optional argument USE-CACHE is non-nil, make use of a cache. See +`org-get-outline-path' for details. + +Assume buffer is widened and point is on a headline." + (or (and use-cache (cdr (assq (point) org-outline-path-cache))) + (let ((p (point)) + (heading (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp) + (if (not (match-end 4)) "" + ;; Remove statistics cookies. + (org-trim + (org-link-display-format + (replace-regexp-in-string + "\\[[0-9]+%\\]\\|\\[[0-9]+/[0-9]+\\]" "" + (match-string-no-properties 4)))))))) + (if (org-up-heading-safe) + (let ((path (cons heading (org--get-outline-path-1 use-cache)))) + (when use-cache + (push (cons p path) org-outline-path-cache)) + path) + ;; This is a new root node. Since we assume we are moving + ;; forward, we can drop previous cache so as to limit number + ;; of associations there. + (let ((path (list heading))) + (when use-cache (setq org-outline-path-cache (list (cons p path)))) + path))))) + +(defun org-get-outline-path (&optional with-self use-cache) + "Return the outline path to the current entry. + +An outline path is a list of ancestors for current headline, as +a list of strings. Statistics cookies are removed and links are +replaced with their description, if any, or their path otherwise. + +When optional argument WITH-SELF is non-nil, the path also +includes the current headline. + +When optional argument USE-CACHE is non-nil, cache outline paths +between calls to this function so as to avoid backtracking. This +argument is useful when planning to find more than one outline +path in the same document. In that case, there are two +conditions to satisfy: + - `org-outline-path-cache' is set to nil before starting the + process; + - outline paths are computed by increasing buffer positions." + (org-with-wide-buffer + (and (or (and with-self (org-back-to-heading t)) + (org-up-heading-safe)) + (reverse (org--get-outline-path-1 use-cache))))) (defun org-format-outline-path (path &optional width prefix separator) "Format the outline path PATH for display. @@ -11467,38 +11804,28 @@ such as the file name. SEPARATOR is inserted between the different parts of the path, the default is \"/\"." (setq width (or width 79)) - (if prefix (setq width (- width (length prefix)))) - (if (not path) - (or prefix "") - (let* ((nsteps (length path)) - (total-width (+ nsteps (apply '+ (mapcar 'length path)))) - (maxwidth (if (<= total-width width) - 10000 ;; everything fits - ;; we need to shorten the level headings - (/ (- width nsteps) nsteps))) - (org-odd-levels-only nil) - (n 0) - (total (1+ (length prefix)))) - (setq maxwidth (max maxwidth 10)) - (concat prefix - (if prefix (or separator "/")) - (mapconcat - (lambda (h) - (setq n (1+ n)) - (if (and (= n nsteps) (< maxwidth 10000)) - (setq maxwidth (- total-width total))) - (if (< (length h) maxwidth) - (progn (setq total (+ total (length h) 1)) h) - (setq h (substring h 0 (- maxwidth 2)) - total (+ total maxwidth 1)) - (if (string-match "[ \t]+\\'" h) - (setq h (substring h 0 (match-beginning 0)))) - (setq h (concat h ".."))) - (org-add-props h nil 'face - (nth (% (1- n) org-n-level-faces) - org-level-faces)) - h) - path (or separator "/")))))) + (setq path (delq nil path)) + (unless (> width 0) + (user-error "Argument `width' must be positive")) + (setq separator (or separator "/")) + (let* ((org-odd-levels-only nil) + (fpath (concat + prefix (and prefix path separator) + (mapconcat + (lambda (s) (replace-regexp-in-string "[ \t]+\\'" "" s)) + (cl-loop for head in path + for n from 0 + collect (org-add-props + head nil 'face + (nth (% n org-n-level-faces) org-level-faces))) + separator)))) + (when (> (length fpath) width) + (if (< width 7) + ;; It's unlikely that `width' will be this small, but don't + ;; waste characters by adding ".." if it is. + (setq fpath (substring fpath 0 width)) + (setf (substring fpath (- width 2)) ".."))) + fpath)) (defun org-display-outline-path (&optional file current separator just-return-string) "Display the current outline path in the echo area. @@ -11513,10 +11840,10 @@ If JUST-RETURN-STRING is non-nil, return a string, don't display a message." (bfn (buffer-file-name (buffer-base-buffer))) (path (and (derived-mode-p 'org-mode) (org-get-outline-path))) res) - (if current (setq path (append path - (save-excursion - (org-back-to-heading t) - (if (looking-at org-complex-heading-regexp) + (when current (setq path (append path + (save-excursion + (org-back-to-heading t) + (when (looking-at org-complex-heading-regexp) (list (match-string 4))))))) (setq res (org-format-outline-path @@ -11546,25 +11873,27 @@ the *old* location.") (let ((org-refile-keep t)) (funcall 'org-refile nil nil nil "Copy"))) -(defun org-refile (&optional goto default-buffer rfloc msg) +(defun org-refile (&optional arg default-buffer rfloc msg) "Move the entry or entries at point to another heading. + The list of target headings is compiled using the information in `org-refile-targets', which see. -At the target location, the entry is filed as a subitem of the target -heading. Depending on `org-reverse-note-order', the new subitem will -either be the first or the last subitem. +At the target location, the entry is filed as a subitem of the +target heading. Depending on `org-reverse-note-order', the new +subitem will either be the first or the last subitem. -If there is an active region, all entries in that region will be moved. -However, the region must fulfill the requirement that the first heading -is the first one sets the top-level of the moved text - at most siblings -below it are allowed. +If there is an active region, all entries in that region will be +refiled. However, the region must fulfill the requirement that +the first heading sets the top-level of the moved text. -With prefix arg GOTO, the command will only visit the target location +With a `\\[universal-argument]' ARG, the command will only visit the target \ +location and not actually move anything. -With a double prefix arg \\[universal-argument] \\[universal-argument], \ -go to the location where the last refiling operation has put the subtree. +With a prefix `\\[universal-argument] \\[universal-argument]', go to the \ +location where the last +refiling operation has put the subtree. With a numeric prefix argument of `2', refile to the running clock. @@ -11578,26 +11907,23 @@ RFLOC can be a refile location obtained in a different way. MSG is a string to replace \"Refile\" in the default prompt with another verb. E.g. `org-copy' sets this parameter to \"Copy\". -See also `org-refile-use-outline-path' and `org-completion-use-ido'. +See also `org-refile-use-outline-path'. -If you are using target caching (see `org-refile-use-cache'), -you have to clear the target cache in order to find new targets. -This can be done with a 0 prefix (`C-0 C-c C-w') or a triple +If you are using target caching (see `org-refile-use-cache'), you +have to clear the target cache in order to find new targets. +This can be done with a `0' prefix (`C-0 C-c C-w') or a triple prefix argument (`C-u C-u C-u C-c C-w')." - (interactive "P") - (if (member goto '(0 (64))) + (if (member arg '(0 (64))) (org-refile-cache-clear) (let* ((actionmsg (cond (msg msg) - ((equal goto 3) "Refile (and keep)") + ((equal arg 3) "Refile (and keep)") (t "Refile"))) - (cbuf (current-buffer)) (regionp (org-region-active-p)) (region-start (and regionp (region-beginning))) (region-end (and regionp (region-end))) - (filename (buffer-file-name (buffer-base-buffer cbuf))) - (org-refile-keep (if (equal goto 3) t org-refile-keep)) - pos it nbuf file re level reversed) + (org-refile-keep (if (equal arg 3) t org-refile-keep)) + pos it nbuf file level reversed) (setq last-command nil) (when regionp (goto-char region-start) @@ -11610,10 +11936,10 @@ prefix argument (`C-u C-u C-u C-c C-w')." (org-toggle-heading) (setq region-end (+ (- (point-at-eol) s) region-end))))) (user-error "The region is not a (sequence of) subtree(s)"))) - (if (equal goto '(16)) + (if (equal arg '(16)) (org-refile-goto-last-stored) (when (or - (and (equal goto 2) + (and (equal arg 2) org-clock-hd-marker (marker-buffer org-clock-hd-marker) (prog1 (setq it (list (or org-clock-heading "running clock") @@ -11621,43 +11947,44 @@ prefix argument (`C-u C-u C-u C-c C-w')." (marker-buffer org-clock-hd-marker)) "" (marker-position org-clock-hd-marker))) - (setq goto nil))) - (setq it (or rfloc - (let (heading-text) - (save-excursion - (unless (and goto (listp goto)) - (org-back-to-heading t) - (setq heading-text - (nth 4 (org-heading-components)))) - - (org-refile-get-location - (cond ((and goto (listp goto)) "Goto") - (regionp (concat actionmsg " region to")) - (t (concat actionmsg " subtree \"" - heading-text "\" to"))) - default-buffer - (and (not (equal '(4) goto)) - org-refile-allow-creating-parent-nodes) - goto)))))) + (setq arg nil))) + (setq it + (or rfloc + (let (heading-text) + (save-excursion + (unless (and arg (listp arg)) + (org-back-to-heading t) + (setq heading-text + (replace-regexp-in-string + org-bracket-link-regexp + "\\3" + (or (nth 4 (org-heading-components)) + "")))) + (org-refile-get-location + (cond ((and arg (listp arg)) "Goto") + (regionp (concat actionmsg " region to")) + (t (concat actionmsg " subtree \"" + heading-text "\" to"))) + default-buffer + (and (not (equal '(4) arg)) + org-refile-allow-creating-parent-nodes))))))) (setq file (nth 1 it) - re (nth 2 it) pos (nth 3 it)) - (if (and (not goto) - pos - (equal (buffer-file-name) file) - (if regionp - (and (>= pos region-start) - (<= pos region-end)) - (and (>= pos (point)) - (< pos (save-excursion - (org-end-of-subtree t t)))))) - (error "Cannot refile to position inside the tree or region")) - + (when (and (not arg) + pos + (equal (buffer-file-name) file) + (if regionp + (and (>= pos region-start) + (<= pos region-end)) + (and (>= pos (point)) + (< pos (save-excursion + (org-end-of-subtree t t)))))) + (error "Cannot refile to position inside the tree or region")) (setq nbuf (or (find-buffer-visiting file) (find-file-noselect file))) - (if (and goto (not (equal goto 3))) + (if (and arg (not (equal arg 3))) (progn - (org-pop-to-buffer-same-window nbuf) + (pop-to-buffer-same-window nbuf) (goto-char pos) (org-show-context 'org-goto)) (if regionp @@ -11668,50 +11995,48 @@ prefix argument (`C-u C-u C-u C-c C-w')." (with-current-buffer (setq nbuf (or (find-buffer-visiting file) (find-file-noselect file))) (setq reversed (org-notes-order-reversed-p)) - (save-excursion - (save-restriction - (widen) - (if pos - (progn - (goto-char pos) - (looking-at org-outline-regexp) - (setq level (org-get-valid-level (funcall outline-level) 1)) - (goto-char - (if reversed - (or (outline-next-heading) (point-max)) - (or (save-excursion (org-get-next-sibling)) - (org-end-of-subtree t t) - (point-max))))) - (setq level 1) - (if (not reversed) - (goto-char (point-max)) - (goto-char (point-min)) - (or (outline-next-heading) (goto-char (point-max))))) - (if (not (bolp)) (newline)) - (org-paste-subtree level) - (when org-log-refile - (org-add-log-setup 'refile nil nil 'findpos org-log-refile) - (unless (eq org-log-refile 'note) - (save-excursion (org-add-log-note)))) - (and org-auto-align-tags - (let ((org-loop-over-headlines-in-active-region nil)) - (org-set-tags nil t))) - (let ((bookmark-name (plist-get org-bookmark-names-plist - :last-refile))) - (when bookmark-name - (with-demoted-errors - (bookmark-set bookmark-name)))) - ;; If we are refiling for capture, make sure that the - ;; last-capture pointers point here - (when (org-bound-and-true-p org-refile-for-capture) - (let ((bookmark-name (plist-get org-bookmark-names-plist - :last-capture-marker))) - (when bookmark-name - (with-demoted-errors - (bookmark-set bookmark-name)))) - (move-marker org-capture-last-stored-marker (point))) - (if (fboundp 'deactivate-mark) (deactivate-mark)) - (run-hooks 'org-after-refile-insert-hook)))) + (org-with-wide-buffer + (if pos + (progn + (goto-char pos) + (looking-at org-outline-regexp) + (setq level (org-get-valid-level (funcall outline-level) 1)) + (goto-char + (if reversed + (or (outline-next-heading) (point-max)) + (or (save-excursion (org-get-next-sibling)) + (org-end-of-subtree t t) + (point-max))))) + (setq level 1) + (if (not reversed) + (goto-char (point-max)) + (goto-char (point-min)) + (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)))) + (and org-auto-align-tags + (let ((org-loop-over-headlines-in-active-region nil)) + (org-set-tags nil t))) + (let ((bookmark-name (plist-get org-bookmark-names-plist + :last-refile))) + (when bookmark-name + (with-demoted-errors + (bookmark-set bookmark-name)))) + ;; If we are refiling for capture, make sure that the + ;; last-capture pointers point here + (when (bound-and-true-p org-capture-is-refiling) + (let ((bookmark-name (plist-get org-bookmark-names-plist + :last-capture-marker))) + (when bookmark-name + (with-demoted-errors + (bookmark-set bookmark-name)))) + (move-marker org-capture-last-stored-marker (point))) + (when (fboundp 'deactivate-mark) (deactivate-mark)) + (run-hooks 'org-after-refile-insert-hook))) (unless org-refile-keep (if regionp (delete-region (point) (+ (point) (- region-end region-start))) @@ -11726,7 +12051,7 @@ prefix argument (`C-u C-u C-u C-c C-w')." (defun org-refile-goto-last-stored () "Go to the location where the last refile was stored." (interactive) - (bookmark-jump "org-refile-last-stored") + (bookmark-jump (plist-get org-bookmark-names-plist :last-refile)) (message "This is the location of the last refile")) (defun org-refile--get-location (refloc tbl) @@ -11740,35 +12065,22 @@ Also check `org-refile-target-table'." (list (replace-regexp-in-string "/$" "" refloc) (replace-regexp-in-string "\\([^/]\\)$" "\\1/" refloc)))))) -(defun org-refile-get-location (&optional prompt default-buffer new-nodes - no-exclude) +(defun org-refile-get-location (&optional prompt default-buffer new-nodes) "Prompt the user for a refile location, using PROMPT. PROMPT should not be suffixed with a colon and a space, because this function appends the default value from -`org-refile-history' automatically, if that is not empty. -When NO-EXCLUDE is set, do not exclude headlines in the current subtree, -this is used for the GOTO interface." +`org-refile-history' automatically, if that is not empty." (let ((org-refile-targets org-refile-targets) - (org-refile-use-outline-path org-refile-use-outline-path) - excluded-entries) - (when (and (derived-mode-p 'org-mode) - (not org-refile-use-cache) - (not no-exclude)) - (org-map-tree - (lambda() - (setq excluded-entries - (append excluded-entries (list (org-get-heading t t))))))) - (setq org-refile-target-table - (org-refile-get-targets default-buffer excluded-entries))) + (org-refile-use-outline-path org-refile-use-outline-path)) + (setq org-refile-target-table (org-refile-get-targets default-buffer))) (unless org-refile-target-table (user-error "No refile targets")) (let* ((cbuf (current-buffer)) - (partial-completion-mode nil) (cfn (buffer-file-name (buffer-base-buffer cbuf))) (cfunc (if (and org-refile-use-outline-path org-outline-path-complete-in-steps) - 'org-olpath-completing-read - 'org-icompleting-read)) + #'org-olpath-completing-read + #'completing-read)) (extra (if org-refile-use-outline-path "/" "")) (cbnex (concat (buffer-name) extra)) (filename (and cfn (expand-file-name cfn))) @@ -11803,8 +12115,8 @@ this is used for the GOTO interface." (cons (car pa) (if (assoc (car org-refile-history) tbl) org-refile-history (cdr org-refile-history)))) - (if (equal (car org-refile-history) (nth 1 org-refile-history)) - (pop org-refile-history))) + (when (equal (car org-refile-history) (nth 1 org-refile-history)) + (pop org-refile-history))) pa) (if (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ) (progn @@ -11827,20 +12139,18 @@ this is used for the GOTO interface." (pos (nth 3 refile-pointer)) buffer) (if (and (not (markerp pos)) (not file)) - (user-error "Please save the buffer to a file before refiling") + (user-error "Please indicate a target file in the refile path") (when (org-string-nw-p re) (setq buffer (if (markerp pos) (marker-buffer pos) (or (find-buffer-visiting file) (find-file-noselect file)))) (with-current-buffer buffer - (save-excursion - (save-restriction - (widen) - (goto-char pos) - (beginning-of-line 1) - (unless (org-looking-at-p re) - (user-error "Invalid refile position, please clear the cache with `C-0 C-c C-w' before refiling"))))))))) + (org-with-wide-buffer + (goto-char pos) + (beginning-of-line 1) + (unless (looking-at-p re) + (user-error "Invalid refile position, please clear the cache with `C-0 C-c C-w' before refiling")))))))) (defun org-refile-new-child (parent-target child) "Use refile target PARENT-TARGET to add new CHILD below it." @@ -11851,53 +12161,43 @@ this is used for the GOTO interface." level) (with-current-buffer (or (find-buffer-visiting file) (find-file-noselect file)) - (save-excursion - (save-restriction - (widen) - (if pos - (goto-char pos) - (goto-char (point-max)) - (if (not (bolp)) (newline))) - (when (looking-at org-outline-regexp) - (setq level (funcall outline-level)) - (org-end-of-subtree t t)) - (org-back-over-empty-lines) - (insert "\n" (make-string - (if pos (org-get-valid-level level 1) 1) ?*) - " " child "\n") - (beginning-of-line 0) - (list (concat (car parent-target) "/" child) file "" (point))))))) + (org-with-wide-buffer + (if pos + (goto-char pos) + (goto-char (point-max)) + (unless (bolp) (newline))) + (when (looking-at org-outline-regexp) + (setq level (funcall outline-level)) + (org-end-of-subtree t t)) + (org-back-over-empty-lines) + (insert "\n" (make-string + (if pos (org-get-valid-level level 1) 1) ?*) + " " child "\n") + (beginning-of-line 0) + (list (concat (car parent-target) "/" child) file "" (point)))))) (defun org-olpath-completing-read (prompt collection &rest args) "Read an outline path like a file name." - (let ((thetable collection) - (org-completion-use-ido nil) ; does not work with ido. - (org-completion-use-iswitchb nil)) ; or iswitchb - (apply - 'org-icompleting-read prompt - (lambda (string predicate &optional flag) - (let (rtn r f (l (length string))) - (cond - ((eq flag nil) - ;; try completion - (try-completion string thetable)) - ((eq flag t) - ;; all-completions - (setq rtn (all-completions string thetable predicate)) - (mapcar - (lambda (x) - (setq r (substring x l)) - (if (string-match " ([^)]*)$" x) - (setq f (match-string 0 x)) - (setq f "")) - (if (string-match "/" r) - (concat string (substring r 0 (match-end 0)) f) - x)) - rtn)) - ((eq flag 'lambda) - ;; exact match? - (assoc string thetable))))) - args))) + (let ((thetable collection)) + (apply #'completing-read + prompt + (lambda (string predicate &optional flag) + (cond + ((eq flag nil) (try-completion string thetable)) + ((eq flag t) + (let ((l (length string))) + (mapcar (lambda (x) + (let ((r (substring x l)) + (f (if (string-match " ([^)]*)$" x) + (match-string 0 x) + ""))) + (if (string-match "/" r) + (concat string (substring r 0 (match-end 0)) f) + x))) + (all-completions string thetable predicate)))) + ;; Exact match? + ((eq flag 'lambda) (assoc string thetable)))) + args))) ;;;; Dynamic blocks @@ -11910,19 +12210,12 @@ If not found, stay at current position and return nil." (setq pos (and (re-search-forward (concat "^[ \t]*#\\+\\(?:BEGIN\\|begin\\):[ \t]+" name "\\>") nil t) (match-beginning 0)))) - (if pos (goto-char pos)) + (when pos (goto-char pos)) pos)) -(defconst org-dblock-start-re - "^[ \t]*#\\+\\(?:BEGIN\\|begin\\):[ \t]+\\(\\S-+\\)\\([ \t]+\\(.*\\)\\)?" - "Matches the start line of a dynamic block, with parameters.") - -(defconst org-dblock-end-re "^[ \t]*#\\+\\(?:END\\|end\\)\\([: \t\r\n]\\|$\\)" - "Matches the end of a dynamic block.") - (defun org-create-dblock (plist) "Create a dynamic block section, with parameters taken from PLIST. -PLIST must contain a :name entry which is used as name of the block." +PLIST must contain a :name entry which is used as the name of the block." (when (string-match "\\S-" (buffer-substring (point-at-bol) (point-at-eol))) (end-of-line 1) (newline)) @@ -12042,13 +12335,14 @@ This function can be used in a hook." ;;;; Completion +(declare-function org-export-backend-options "ox" (cl-x) t) (defun org-get-export-keywords () "Return a list of all currently understood export keywords. Export keywords include options, block names, attributes and keywords relative to each registered export back-end." (let (keywords) (dolist (backend - (org-bound-and-true-p org-export--registered-backends) + (bound-and-true-p org-export-registered-backends) (delq nil keywords)) ;; Back-end name (for keywords, like #+LATEX:) (push (upcase (symbol-name (org-export-backend-name backend))) keywords) @@ -12064,27 +12358,24 @@ 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" "<src lang=\"?\">\n\n</src>") - ("e" "#+BEGIN_EXAMPLE\n?\n#+END_EXAMPLE" "<example>\n?\n</example>") - ("q" "#+BEGIN_QUOTE\n?\n#+END_QUOTE" "<quote>\n?\n</quote>") - ("v" "#+BEGIN_VERSE\n?\n#+END_VERSE" "<verse>\n?\n</verse>") - ("V" "#+BEGIN_VERBATIM\n?\n#+END_VERBATIM" "<verbatim>\n?\n</verbatim>") - ("c" "#+BEGIN_CENTER\n?\n#+END_CENTER" "<center>\n?\n</center>") - ("l" "#+BEGIN_LaTeX\n?\n#+END_LaTeX" - "<literal style=\"latex\">\n?\n</literal>") - ("L" "#+LaTeX: " "<literal style=\"latex\">?</literal>") - ("h" "#+BEGIN_HTML\n?\n#+END_HTML" - "<literal style=\"html\">\n?\n</literal>") - ("H" "#+HTML: " "<literal style=\"html\">?</literal>") - ("a" "#+BEGIN_ASCII\n?\n#+END_ASCII" "") - ("A" "#+ASCII: " "") - ("i" "#+INDEX: ?" "#+INDEX: ?") - ("I" "#+INCLUDE: %file ?" - "<include file=%file markup=\"?\">")) + '(("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") + ("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 `M-TAB'. %file will be replaced by a file name after prompting +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, @@ -12095,8 +12386,9 @@ variable `org-mtags-prefer-muse-templates'." :type '(repeat (list (string :tag "Key") - (string :tag "Template") - (string :tag "Muse Template")))) + (string :tag "Template"))) + :version "26.1" + :package-version '(Org . "8.3")) (defun org-try-structure-completion () "Try to complete a structure template before point. @@ -12113,29 +12405,28 @@ expands them." (defun org-complete-expand-structure-template (start cell) "Expand a structure template." - (let* ((musep (org-bound-and-true-p org-mtags-prefer-muse-templates)) - (rpl (nth (if musep 2 1) cell)) - (ind "")) + (let ((rpl (nth 1 cell)) + (ind "")) (delete-region start (point)) - (when (string-match "\\`#\\+" rpl) + (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)) - (if (string-match "%file" rpl) - (setq rpl (replace-match - (concat - "\"" - (save-match-data - (abbreviate-file-name (read-file-name "Include file: "))) - "\"") - t t rpl))) + (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) - (if (re-search-backward "\\?" start t) (delete-char 1)))) + (when (re-search-backward "\\?" start t) (delete-char 1)))) ;;;; TODO, DEADLINE, Comments @@ -12144,17 +12435,18 @@ expands them." (interactive) (save-excursion (org-back-to-heading) - (let (case-fold-search) - (cond - ((looking-at (format org-heading-keyword-regexp-format - org-comment-string)) - (goto-char (match-end 1)) - (looking-at (concat " +" org-comment-string)) - (replace-match "" t t) - (when (eolp) (insert " "))) - ((looking-at org-outline-regexp) - (goto-char (match-end 0)) - (insert org-comment-string " ")))))) + (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp)) + (goto-char (or (match-end 3) (match-end 2) (match-end 1))) + (skip-chars-forward " \t") + (unless (memq (char-before) '(?\s ?\t)) (insert " ")) + (if (org-in-commented-heading-p t) + (delete-region (point) + (progn (search-forward " " (line-end-position) 'move) + (skip-chars-forward " \t") + (point))) + (insert org-comment-string) + (unless (eolp) (insert " "))))) (defvar org-last-todo-state-is-todo nil "This is non-nil when the last TODO state change led to a TODO state. @@ -12193,43 +12485,65 @@ nil or a string to be used for the todo mark." ) (interactive "P") (if (eq major-mode 'org-agenda-mode) (apply 'org-agenda-todo-yesterday arg) - (let* ((hour (third (decode-time - (org-current-time)))) + (let* ((org-use-effective-time t) + (hour (nth 2 (decode-time (org-current-time)))) (org-extend-today-until (1+ hour))) (org-todo arg)))) (defvar org-block-entry-blocking "" "First entry preventing the TODO state change.") +(defun org-cancel-repeater () + "Cancel a repeater by setting its numeric value to zero." + (interactive) + (save-excursion + (org-back-to-heading t) + (let ((bound1 (point)) + (bound0 (save-excursion (outline-next-heading) (point)))) + (when (and (re-search-forward + (concat "\\(" org-scheduled-time-regexp "\\)\\|\\(" + org-deadline-time-regexp "\\)\\|\\(" + org-ts-regexp "\\)") + bound0 t) + (re-search-backward "[ \t]+\\(?:[.+]\\)?\\+\\([0-9]+\\)[hdwmy]" + bound1 t)) + (replace-match "0" t nil nil 1))))) + +(defvar org-state) +(defvar org-blocked-by-checkboxes) (defun org-todo (&optional arg) "Change the TODO state of an item. + The state of an item is given by a keyword at the start of the heading, like *** TODO Write paper *** DONE Call mom The different keywords are specified in the variable `org-todo-keywords'. -By default the available states are \"TODO\" and \"DONE\". -So for this example: when the item starts with TODO, it is changed to DONE. +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. -With \\[universal-argument] prefix arg, use completion to determine the new \ +With `\\[universal-argument]' prefix ARG, use completion to determine the new \ state. -With numeric prefix arg, switch to that state. -With a double \\[universal-argument] prefix, switch to the next set of TODO \ +With numeric prefix ARG, switch to that state. +With a `\\[universal-argument] \\[universal-argument]' prefix, switch to the \ +next set of TODO \ keywords (nextset). -With a triple \\[universal-argument] prefix, circumvent any state blocking. +With a `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \ +prefix, circumvent any state blocking. With a numeric prefix arg of 0, inhibit note taking for the change. - -For calling through lisp, arg is also interpreted in the following way: -`none' -> empty state -\"\" (empty string) -> switch to empty state -`done' -> switch to DONE -`nextset' -> switch to the next set of keywords -`previousset' -> switch to the previous set of keywords -\"WAITING\" -> switch to the specified keyword, but only if it - really is a member of `org-todo-keywords'." +With a numeric prefix arg of -1, cancel repeater to allow marking as DONE. + +When called through ELisp, arg is also interpreted in the following way: +`none' -> empty state +\"\" -> switch to empty state +`done' -> switch to DONE +`nextset' -> switch to the next set of keywords +`previousset' -> switch to the previous set of keywords +\"WAITING\" -> switch to the specified keyword, but only if it + really is a member of `org-todo-keywords'." (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) @@ -12238,8 +12552,9 @@ For calling through lisp, arg is also interpreted in the following way: (org-map-entries `(org-todo ,arg) org-loop-over-headlines-in-active-region - cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) - (if (equal arg '(16)) (setq arg 'nextset)) + cl (when (org-invisible-p) (org-end-of-subtree nil t)))) + (when (equal arg '(16)) (setq arg 'nextset)) + (when (equal arg -1) (org-cancel-repeater) (setq arg nil)) (let ((org-blocker-hook org-blocker-hook) commentp case-fold-search) @@ -12252,10 +12567,10 @@ For calling through lisp, arg is also interpreted in the following way: (save-excursion (catch 'exit (org-back-to-heading t) - (when (looking-at (concat "^\\*+ " org-comment-string)) + (when (org-in-commented-heading-p t) (org-toggle-comment) (setq commentp t)) - (if (looking-at org-outline-regexp) (goto-char (1- (match-end 0)))) + (when (looking-at org-outline-regexp) (goto-char (1- (match-end 0)))) (or (looking-at (concat " +" org-todo-regexp "\\( +\\|[ \t]*$\\)")) (looking-at "\\(?: *\\|[ \t]*$\\)")) (let* ((match-data (match-data)) @@ -12285,31 +12600,30 @@ For calling through lisp, arg is also interpreted in the following way: (and (not arg) org-use-fast-todo-selection (not (eq org-use-fast-todo-selection 'prefix))))) - ;; Use fast selection + ;; 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 - (org-icompleting-read - "State: " (mapcar 'list org-todo-keywords-1) + ;; Read a state with completion. + (completing-read + "State: " (mapcar #'list org-todo-keywords-1) nil t)) ((eq arg 'right) (if this (if tail (car tail) nil) (car org-todo-keywords-1))) ((eq arg 'left) - (if (equal member org-todo-keywords-1) - nil + (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 + (setq arg nil))) ;hack to fall back to cycling (arg - ;; user or caller requests a specific state + ;; User or caller requests a specific state. (cond ((equal arg "") nil) ((eq arg 'none) nil) @@ -12327,8 +12641,8 @@ For calling through lisp, arg is also interpreted in the following way: ((nth (1- (prefix-numeric-value arg)) org-todo-keywords-1)))) ((null member) (or head (car org-todo-keywords-1))) - ((equal this final-done-word) nil) ;; -> make empty - ((null tail) nil) ;; -> first entry + ((equal this final-done-word) nil) ;-> make empty + ((null tail) nil) ;-> first entry ((memq interpret '(type priority)) (if (eq this-command last-command) (car tail) @@ -12346,24 +12660,30 @@ For calling through lisp, arg is also interpreted in the following way: :position startpos)) dolog now-done-p) (when org-blocker-hook - (setq org-last-todo-state-is-todo - (not (member this org-done-keywords))) - (unless (save-excursion - (save-match-data - (org-with-wide-buffer - (run-hook-with-args-until-failure - 'org-blocker-hook change-plist)))) - (if (org-called-interactively-p 'interactive) - (user-error "TODO state change from %s to %s blocked (by \"%s\")" - this org-state org-block-entry-blocking) - ;; fail silently - (message "TODO state change from %s to %s blocked (by \"%s\")" - this org-state org-block-entry-blocking) - (throw 'exit nil)))) + (let (org-blocked-by-checkboxes block-reason) + (setq org-last-todo-state-is-todo + (not (member this org-done-keywords))) + (unless (save-excursion + (save-match-data + (org-with-wide-buffer + (run-hook-with-args-until-failure + 'org-blocker-hook change-plist)))) + (setq block-reason (if org-blocked-by-checkboxes + "contained checkboxes" + (format "\"%s\"" org-block-entry-blocking))) + (if (called-interactively-p 'interactive) + (user-error "TODO state change from %s to %s blocked (by %s)" + this org-state block-reason) + ;; Fail silently. + (message "TODO state change from %s to %s blocked (by %s)" + this org-state block-reason) + (throw 'exit nil))))) (store-match-data match-data) (replace-match next t t) - (unless (pos-visible-in-window-p hl-pos) - (message "TODO state changed to %s" (org-trim next))) + (cond ((equal this org-state) + (message "TODO state was already %s" (org-trim next))) + ((pos-visible-in-window-p hl-pos) + (message "TODO state changed to %s" (org-trim next)))) (unless head (setq head (org-get-todo-sequence-head org-state) ass (assoc head org-todo-kwd-alist) @@ -12384,11 +12704,11 @@ For calling through lisp, arg is also interpreted in the following way: (when (and (or org-todo-log-states org-log-done) (not (eq org-inhibit-logging t)) (not (memq arg '(nextset previousset)))) - ;; we need to look at recording a time and note + ;; We need to look at recording a time and note. (setq dolog (or (nth 1 (assoc org-state org-todo-log-states)) (nth 2 (assoc this org-todo-log-states)))) - (if (and (eq dolog 'note) (eq org-inhibit-logging 'note)) - (setq dolog 'time)) + (when (and (eq dolog 'note) (eq org-inhibit-logging 'note)) + (setq dolog 'time)) (when (or (and (not org-state) (not org-closed-keep-when-no-todo)) (and org-state (member org-state org-not-done-keywords) @@ -12397,21 +12717,21 @@ For calling through lisp, arg is also interpreted in the following way: ;; If there was a CLOSED time stamp, get rid of it. (org-add-planning-info nil nil 'closed)) (when (and now-done-p org-log-done) - ;; It is now done, and it was not done before + ;; It is now done, and it was not done before. (org-add-planning-info 'closed (org-current-effective-time)) - (if (and (not dolog) (eq 'note org-log-done)) - (org-add-log-setup 'done org-state this 'findpos 'note))) + (when (and (not dolog) (eq 'note org-log-done)) + (org-add-log-setup 'done org-state this 'note))) (when (and org-state dolog) - ;; This is a non-nil state, and we need to log it - (org-add-log-setup 'state org-state this 'findpos dolog))) - ;; Fixup tag positioning + ;; This is a non-nil state, and we need to log it. + (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-provide-todo-statistics (org-update-parent-todo-statistics)) (run-hooks 'org-after-todo-state-change-hook) - (if (and arg (not (member org-state org-done-keywords))) - (setq head (org-get-todo-sequence-head org-state))) + (when (and arg (not (member org-state org-done-keywords))) + (setq head (org-get-todo-sequence-head org-state))) (put-text-property (point-at-bol) (point-at-eol) 'org-todo-head head) ;; Do we need to trigger a repeat? (when now-done-p @@ -12421,15 +12741,14 @@ For calling through lisp, arg is also interpreted in the following way: (setq org-agenda-headline-snapshot-before-repeat (org-get-heading)))) (org-auto-repeat-maybe org-state)) - ;; Fixup cursor location if close to the keyword - (if (and (outline-on-heading-p) - (not (bolp)) - (save-excursion (beginning-of-line 1) - (looking-at org-todo-line-regexp)) - (< (point) (+ 2 (or (match-end 2) (match-end 1))))) - (progn - (goto-char (or (match-end 2) (match-end 1))) - (and (looking-at " ") (just-one-space)))) + ;; Fixup cursor location if close to the keyword. + (when (and (outline-on-heading-p) + (not (bolp)) + (save-excursion (beginning-of-line 1) + (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))) (when org-trigger-hook (save-excursion (run-hook-with-args 'org-trigger-hook change-plist))) @@ -12471,10 +12790,10 @@ changes. Such blocking occurs when: (> child-level this-level)) ;; this todo has children, check whether they are all ;; completed - (if (and (not (org-entry-is-done-p)) - (org-entry-is-todo-p)) - (progn (setq org-block-entry-blocking (org-get-heading)) - (throw 'dont-block nil))) + (when (and (not (org-entry-is-done-p)) + (org-entry-is-todo-p)) + (setq org-block-entry-blocking (org-get-heading)) + (throw 'dont-block nil)) (outline-next-heading) (setq child-level (funcall outline-level)))))) ;; Otherwise, if the task's parent has the :ORDERED: property, and @@ -12482,8 +12801,9 @@ changes. Such blocking occurs when: (save-excursion (org-back-to-heading t) (let* ((pos (point)) - (parent-pos (and (org-up-heading-safe) (point)))) - (if (not parent-pos) (throw 'dont-block t)) ; no parent + (parent-pos (and (org-up-heading-safe) (point))) + (case-fold-search nil)) + (unless parent-pos (throw 'dont-block t)) ; no parent (when (and (org-not-nil (org-entry-get (point) "ORDERED")) (forward-line 1) (re-search-forward org-not-done-heading-regexp pos t)) @@ -12492,11 +12812,11 @@ changes. Such blocking occurs when: ;; Search further up the hierarchy, to see if an ancestor is blocked (while t (goto-char parent-pos) - (if (not (looking-at org-not-done-heading-regexp)) - (throw 'dont-block t)) ; do not block, parent is not a TODO + (unless (looking-at org-not-done-heading-regexp) + (throw 'dont-block t)) ; do not block, parent is not a TODO (setq pos (point)) (setq parent-pos (and (org-up-heading-safe) (point))) - (if (not parent-pos) (throw 'dont-block t)) ; no parent + (unless parent-pos (throw 'dont-block t)) ; no parent (when (and (org-not-nil (org-entry-get (point) "ORDERED")) (forward-line 1) (re-search-forward org-not-done-heading-regexp pos t) @@ -12533,14 +12853,13 @@ See variable `org-track-ordered-property-with-tag'." (org-back-to-heading) (if (org-entry-get nil "ORDERED") (progn - (org-delete-property "ORDERED" "PROPERTIES") + (org-delete-property "ORDERED") (and tag (org-toggle-tag tag 'off)) (message "Subtasks can be completed in arbitrary order")) (org-entry-put nil "ORDERED" "t") (and tag (org-toggle-tag tag 'on)) (message "Subtasks must be completed in sequence"))))) -(defvar org-blocked-by-checkboxes) ; dynamically scoped (defun org-block-todo-from-checkboxes (change-plist) "Block turning an entry into a TODO, using checkboxes. This checks whether the current task should be blocked from state @@ -12564,32 +12883,32 @@ changes because there are unchecked boxes in this entry." (outline-next-heading) (setq end (point)) (goto-char beg) - (if (org-list-search-forward - (concat (org-item-beginning-re) - "\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*\\)?" - "\\[[- ]\\]") - end t) - (progn - (if (boundp 'org-blocked-by-checkboxes) - (setq org-blocked-by-checkboxes t)) - (throw 'dont-block nil))))) + (when (org-list-search-forward + (concat (org-item-beginning-re) + "\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*\\)?" + "\\[[- ]\\]") + end t) + (when (boundp 'org-blocked-by-checkboxes) + (setq org-blocked-by-checkboxes t)) + (throw 'dont-block nil)))) t))) ; do not block (defun org-entry-blocked-p () - "Is the current entry blocked?" - (org-with-silent-modifications - (if (org-entry-get nil "NOBLOCKING") - nil ;; Never block this entry - (not (run-hook-with-args-until-failure - 'org-blocker-hook - (list :type 'todo-state-change - :position (point) - :from 'todo - :to 'done)))))) + "Non-nil if entry at point is blocked." + (and (not (org-entry-get nil "NOBLOCKING")) + (member (org-entry-get nil "TODO") org-not-done-keywords) + (not (run-hook-with-args-until-failure + 'org-blocker-hook + (list :type 'todo-state-change + :position (point) + :from 'todo + :to 'done))))) (defun org-update-statistics-cookies (all) "Update the statistics cookie, either from TODO or from checkboxes. -This should be called with the cursor in a line with a statistics cookie." +This should be called with the cursor in a line with a statistics +cookie. When called with a \\[universal-argument] prefix, update +all statistics cookies in the buffer." (interactive "P") (if all (progn @@ -12605,7 +12924,7 @@ This should be called with the cursor in a line with a statistics cookie." (setq l1 (org-outline-level)) (setq end (save-excursion (outline-next-heading) - (if (org-at-heading-p) (setq l2 (org-outline-level))) + (when (org-at-heading-p) (setq l2 (org-outline-level))) (point))) (if (and (save-excursion (re-search-forward @@ -12642,7 +12961,7 @@ statistics everywhere." (box-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)") level ltoggle l1 new ndel (cnt-all 0) (cnt-done 0) is-percent kwd - checkbox-beg ov ovs ove cookie-present) + checkbox-beg cookie-present) (catch 'exit (save-excursion (beginning-of-line 1) @@ -12677,14 +12996,31 @@ statistics everywhere." (setq kwd (and (or recursive (= l1 ltoggle)) (match-string 2))) (if (or (eq org-provide-todo-statistics 'all-headlines) + (and (eq org-provide-todo-statistics t) + (or (member kwd org-done-keywords))) (and (listp org-provide-todo-statistics) + (stringp (car org-provide-todo-statistics)) (or (member kwd org-provide-todo-statistics) - (member kwd org-done-keywords)))) + (member kwd org-done-keywords))) + (and (listp org-provide-todo-statistics) + (listp (car org-provide-todo-statistics)) + (or (member kwd (car org-provide-todo-statistics)) + (and (member kwd org-done-keywords) + (member kwd (cadr org-provide-todo-statistics)))))) (setq cnt-all (1+ cnt-all)) - (if (eq org-provide-todo-statistics t) - (and kwd (setq cnt-all (1+ cnt-all))))) - (and (member kwd org-done-keywords) - (setq cnt-done (1+ cnt-done))) + (and (eq org-provide-todo-statistics t) + kwd + (setq cnt-all (1+ cnt-all)))) + (when (or (and (member org-provide-todo-statistics '(t all-headlines)) + (member kwd org-done-keywords)) + (and (listp org-provide-todo-statistics) + (listp (car org-provide-todo-statistics)) + (member kwd org-done-keywords) + (member kwd (cadr org-provide-todo-statistics))) + (and (listp org-provide-todo-statistics) + (stringp (car org-provide-todo-statistics)) + (member kwd org-done-keywords))) + (setq cnt-done (1+ cnt-done))) (outline-next-heading))) (setq new (if is-percent @@ -12692,15 +13028,10 @@ statistics everywhere." (max 1 cnt-all))) (format "[%d/%d]" cnt-done cnt-all)) ndel (- (match-end 0) checkbox-beg)) - ;; handle overlays when updating cookie from column view - (when (setq ov (car (overlays-at checkbox-beg))) - (setq ovs (overlay-start ov) ove (overlay-end ov)) - (delete-overlay ov)) (goto-char checkbox-beg) (insert new) (delete-region (point) (+ (point) ndel)) - (when org-auto-align-tags (org-fix-tags-on-the-fly)) - (when ov (move-overlay ov ovs ove))) + (when org-auto-align-tags (org-fix-tags-on-the-fly))) (when cookie-present (run-hook-with-args 'org-after-todo-statistics-hook cnt-done (- cnt-all cnt-done)))))) @@ -12736,9 +13067,9 @@ This hook runs even if there is no statistics cookie present, in which case (when (and (stringp state) (> (length state) 0)) (setq changes (append changes (cdr (assoc state l))))) (when (member state org-not-done-keywords) - (setq changes (append changes (cdr (assoc 'todo l))))) + (setq changes (append changes (cdr (assq 'todo l))))) (when (member state org-done-keywords) - (setq changes (append changes (cdr (assoc 'done l))))) + (setq changes (append changes (cdr (assq 'done l))))) (dolist (c changes) (org-toggle-tag (car c) (if (cdr c) 'on 'off))))) @@ -12749,7 +13080,7 @@ This hook runs even if there is no statistics cookie present, in which case org-log-repeat nil org-todo-log-states nil) (dolist (w (org-split-string value)) - (let* (a) + (let (a) (cond ((setq a (assoc w org-startup-options)) (and (member (nth 1 a) '(org-log-done org-log-repeat)) @@ -12786,7 +13117,7 @@ Returns the new TODO keyword, or nil if no state change should occur." (expert nil) (fwidth (+ maxlen 3 1 3)) (ncol (/ (- (window-width) 4) fwidth)) - tg cnt c tbl + tg cnt e c tbl groups ingroup) (save-excursion (save-window-excursion @@ -12794,13 +13125,13 @@ Returns the new TODO keyword, or nil if no state change should occur." (set-buffer (get-buffer-create " *Org todo*")) (org-switch-to-buffer-other-window (get-buffer-create " *Org todo*"))) (erase-buffer) - (org-set-local 'org-done-keywords done-keywords) + (setq-local org-done-keywords done-keywords) (setq tbl fulltable cnt 0) - (dolist (e tbl) + (while (setq e (pop tbl)) (cond ((equal e '(:startgroup)) (push '() groups) (setq ingroup t) - (when (not (= cnt 0)) + (unless (= cnt 0) (setq cnt 0) (insert "\n")) (insert "{ ")) @@ -12808,7 +13139,7 @@ Returns the new TODO keyword, or nil if no state change should occur." (setq ingroup nil cnt 0) (insert "}\n")) ((equal e '(:newline)) - (when (not (= cnt 0)) + (unless (= cnt 0) (setq cnt 0) (insert "\n") (setq e (car tbl)) @@ -12817,19 +13148,19 @@ 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 ingroup (push tg (car groups))) + (when ingroup (push tg (car groups))) (setq tg (org-add-props tg nil 'face (org-get-todo-face tg))) - (if (and (= cnt 0) (not ingroup)) (insert " ")) + (when (and (= cnt 0) (not ingroup)) (insert " ")) (insert "[" c "] " tg (make-string (- fwidth 4 (length tg)) ?\ )) (when (= (setq cnt (1+ cnt)) ncol) (insert "\n") - (if ingroup (insert " ")) + (when ingroup (insert " ")) (setq cnt 0))))) (insert "\n") (goto-char (point-min)) - (if (not expert) (org-fit-window-to-buffer)) + (unless expert (org-fit-window-to-buffer)) (message "[a-z..]:Set [SPC]:clear") (setq c (let ((inhibit-quit t)) (read-char-exclusive))) (cond @@ -12851,12 +13182,19 @@ Returns the new TODO keyword, or nil if no state change should occur." "Return the TODO keyword of the current subtree." (save-excursion (org-back-to-heading t) - (and (looking-at org-todo-line-regexp) + (and (let ((case-fold-search nil)) (looking-at org-todo-line-regexp)) (match-end 2) (match-string 2)))) (defun org-at-date-range-p (&optional inactive-ok) - "Is the cursor inside a date range?" + "Non-nil if point is inside a date range. + +When optional argument INACTIVE-OK is non-nil, also consider +inactive time ranges. + +When this function returns a non-nil value, match data is set +according to `org-tr-regexp-both' or `org-tr-regexp', depending +on INACTIVE-OK." (interactive) (save-excursion (catch 'exit @@ -12888,14 +13226,15 @@ Returns the new TODO keyword, or nil if no state change should occur." (defvar org-last-inserted-timestamp) (defvar org-log-post-message) (defvar org-log-note-purpose) -(defvar org-log-note-how) +(defvar org-log-note-how nil) (defvar org-log-note-extra) (defun org-auto-repeat-maybe (done-word) - "Check if the current headline contains a repeated deadline/schedule. + "Check if the current headline contains a repeated time-stamp. + If yes, set TODO state back to what it was and change the base date of repeating deadline/scheduled time stamps to new date. + This function is run automatically after each state change to a DONE state." - ;; last-state is dynamically scoped into this function (let* ((repeat (org-get-repeat)) (aa (assoc org-last-state org-todo-kwd-alist)) (interpret (nth 1 aa)) @@ -12903,73 +13242,108 @@ This function is run automatically after each state change to a DONE state." (whata '(("h" . hour) ("d" . day) ("m" . month) ("y" . year))) (msg "Entry repeats: ") (org-log-done nil) - (org-todo-log-states nil) - re type n what ts time to-state) - (when repeat - (if (eq org-log-repeat t) (setq org-log-repeat 'state)) - (setq to-state (or (org-entry-get nil "REPEAT_TO_STATE") - org-todo-repeat-to-state)) - (unless (and to-state (member to-state org-todo-keywords-1)) - (setq to-state (if (eq interpret 'type) org-last-state head))) - (org-todo to-state) + (org-todo-log-states nil)) + (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)))) (when (or org-log-repeat (org-entry-get nil "CLOCK")) (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)) - ;; OK, we are already setup for some record - (if (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)) + ;; 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 - 'findpos org-log-repeat))) + org-log-repeat))) (org-back-to-heading t) (org-add-planning-info nil nil 'closed) - (setq re (concat "\\(" org-scheduled-time-regexp "\\)\\|\\(" - org-deadline-time-regexp "\\)\\|\\(" - org-ts-regexp "\\)")) - (while (re-search-forward - re (save-excursion (outline-next-heading) (point)) t) - (setq type (if (match-end 1) org-scheduled-string - (if (match-end 3) org-deadline-string "Plain:")) - ts (match-string (if (match-end 2) 2 (if (match-end 4) 4 0)))) - (when (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)" ts) - (setq n (string-to-number (match-string 2 ts)) - what (match-string 3 ts)) - (if (equal what "w") (setq n (* n 7) what "d")) - (if (and (equal what "h") (not (string-match "[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) - (setq time (save-match-data (org-time-string-to-time ts))) + (let ((end (save-excursion (outline-next-heading) (point))) + (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 - ((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) - (<= (time-to-days time) - (time-to-days (current-time)))) - (when (= (incf nshift) nshiftmax) - (or (y-or-n-p (message "%d repeater intervals were not enough to shift date past today. Continue? " nshift)) - (error "Abort"))) - (org-timestamp-change n (cdr (assoc what whata))) - (org-at-timestamp-p t) - (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 - (org-at-timestamp-p t) - (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 " ")))) + ;; Ignore fake time-stamps (e.g., within comments). + ((and (not planning?) + (not (org-at-property-p)) + (not (eq 'timestamp + (org-element-type (save-excursion + (backward-char) + (org-element-context))))))) + ;; Time-stamps without a repeater are usually skipped. + ;; However, a SCHEDULED time-stamp without one is + ;; removed, as it is considered as 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 (current-time) time))) + (when (= (cl-incf nshift) nshiftmax) + (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-at-timestamp-p t) + (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. + (org-at-timestamp-p t) + (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)))) @@ -12977,7 +13351,7 @@ This function is run automatically after each state change to a DONE state." "Make a compact tree which shows all headlines marked with TODO. The tree will show the lines where the regexp matches, and all higher headlines above the match. -With a \\[universal-argument] prefix, prompt for a regexp to match. +With a `\\[universal-argument]' prefix, prompt for a regexp to match. With a numeric prefix N, construct a sparse tree for the Nth element of `org-todo-keywords-1'." (interactive "P") @@ -12985,8 +13359,9 @@ of `org-todo-keywords-1'." (kwd-re (cond ((null arg) org-not-done-regexp) ((equal arg '(4)) - (let ((kwd (org-icompleting-read "Keyword (or KWD1|KWD2|...): " - (mapcar 'list org-todo-keywords-1)))) + (let ((kwd + (completing-read "Keyword (or KWD1|KWD2|...): " + (mapcar #'list org-todo-keywords-1)))) (concat "\\(" (mapconcat 'identity (org-split-string kwd "|") "\\|") "\\)\\>"))) @@ -12997,6 +13372,83 @@ of `org-todo-keywords-1'." (message "%d TODO entries found" (org-occur (concat "^" org-outline-regexp " *" kwd-re ))))) +(defun org--deadline-or-schedule (arg type time) + "Insert DEADLINE or SCHEDULE information in current entry. +TYPE is either `deadline' or `scheduled'. See `org-deadline' or +`org-schedule' for information about ARG and TIME arguments." + (let* ((deadline? (eq type 'deadline)) + (keyword (if deadline? org-deadline-string org-scheduled-string)) + (log (if deadline? org-log-redeadline org-log-reschedule)) + (old-date (org-entry-get nil (if deadline? "DEADLINE" "SCHEDULED"))) + (old-date-time (and old-date (org-time-string-to-time old-date))) + ;; Save repeater cookie from either TIME or current scheduled + ;; time stamp. We are going to insert it back at the end of + ;; the process. + (repeater (or (and (org-string-nw-p time) + ;; We use `org-repeat-re' because we need + ;; to tell the difference between a real + ;; repeater and a time delta, e.g. "+2d". + (string-match org-repeat-re time) + (match-string 1 time)) + (and (org-string-nw-p old-date) + (string-match "\\([.+-]+[0-9]+[hdwmy]\ +\\(?:[/ ][-+]?[0-9]+[hdwmy]\\)?\\)" + old-date) + (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."))) + (`(16) + (save-excursion + (org-back-to-heading t) + (let ((regexp (if deadline? org-deadline-time-regexp + org-scheduled-time-regexp))) + (if (not (re-search-forward regexp (line-end-position 2) t)) + (user-error (if deadline? "No deadline information to update" + "No scheduled information to update")) + (let* ((rpl0 (match-string 1)) + (rpl (replace-regexp-in-string " -[0-9]+[hdwmy]" "" rpl0)) + (msg (if deadline? "Warn starting from" "Delay until"))) + (replace-match + (concat keyword + " <" rpl + (format " -%dd" + (abs (- (time-to-days + (save-match-data + (org-read-date + nil t nil msg old-date-time))) + (time-to-days old-date-time)))) + ">") t t)))))) + (_ + (org-add-planning-info type time 'closed) + (when (and old-date + log + (not (equal old-date org-last-inserted-timestamp))) + (org-add-log-setup (if deadline? 'redeadline 'reschedule) + org-last-inserted-timestamp + old-date + log)) + (when repeater + (save-excursion + (org-back-to-heading t) + (when (re-search-forward + (concat keyword " " org-last-inserted-timestamp) + (line-end-position 2) + t) + (goto-char (1- (match-end 0))) + (insert " " repeater) + (setq org-last-inserted-timestamp + (concat (substring org-last-inserted-timestamp 0 -1) + " " repeater + (substring org-last-inserted-timestamp -1)))))) + (message (if deadline? "Deadline on %s" "Scheduled to %s") + org-last-inserted-timestamp))))) + (defun org-deadline (arg &optional time) "Insert the \"DEADLINE:\" string with a timestamp to make a deadline. With one universal prefix argument, remove any deadline from the item. @@ -13005,67 +13457,14 @@ With argument TIME, set the deadline at the corresponding date. TIME can either be an Org date like \"2011-07-24\" or a delta like \"+2d\"." (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 - `(org-deadline ',arg ,time) - org-loop-over-headlines-in-active-region - cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) - (let* ((old-date (org-entry-get nil "DEADLINE")) - (old-date-time (if old-date (org-time-string-to-time old-date))) - (repeater (and old-date - (string-match - "\\([.+-]+[0-9]+[hdwmy]\\(?:[/ ][-+]?[0-9]+[hdwmy]\\)?\\) ?" - old-date) - (match-string 1 old-date)))) - (cond - ((equal arg '(4)) - (when (and old-date org-log-redeadline) - (org-add-log-setup 'deldeadline nil old-date 'findpos - org-log-redeadline)) - (org-remove-timestamp-with-keyword org-deadline-string) - (message "Item no longer has a deadline.")) - ((equal arg '(16)) - (save-excursion - (org-back-to-heading t) - (if (re-search-forward - org-deadline-time-regexp - (save-excursion (outline-next-heading) (point)) t) - (let* ((rpl0 (match-string 1)) - (rpl (replace-regexp-in-string " -[0-9]+[hdwmy]" "" rpl0))) - (replace-match - (concat org-deadline-string - " <" rpl - (format " -%dd" - (abs - (- (time-to-days - (save-match-data - (org-read-date nil t nil "Warn starting from" old-date-time))) - (time-to-days old-date-time)))) - ">") t t)) - (user-error "No deadline information to update")))) - (t - (org-add-planning-info 'deadline time 'closed) - (when (and old-date org-log-redeadline - (not (equal old-date - (substring org-last-inserted-timestamp 1 -1)))) - (org-add-log-setup 'redeadline nil old-date 'findpos - org-log-redeadline)) - (when repeater - (save-excursion - (org-back-to-heading t) - (when (re-search-forward (concat org-deadline-string " " - org-last-inserted-timestamp) - (save-excursion - (outline-next-heading) (point)) t) - (goto-char (1- (match-end 0))) - (insert " " repeater) - (setq org-last-inserted-timestamp - (concat (substring org-last-inserted-timestamp 0 -1) - " " repeater - (substring org-last-inserted-timestamp -1)))))) - (message "Deadline on %s" org-last-inserted-timestamp)))))) + (org-map-entries + (lambda () (org--deadline-or-schedule arg 'deadline time)) + 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)))) + (org--deadline-or-schedule arg 'deadline time))) (defun org-schedule (arg &optional time) "Insert the SCHEDULED: string with a timestamp to schedule a TODO item. @@ -13075,68 +13474,14 @@ With argument TIME, scheduled at the corresponding date. TIME can either be an Org date like \"2011-07-24\" or a delta like \"+2d\"." (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 - `(org-schedule ',arg ,time) - org-loop-over-headlines-in-active-region - cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) - (let* ((old-date (org-entry-get nil "SCHEDULED")) - (old-date-time (if old-date (org-time-string-to-time old-date))) - (repeater (and old-date - (string-match - "\\([.+-]+[0-9]+[hdwmy]\\(?:[/ ][-+]?[0-9]+[hdwmy]\\)?\\) ?" - old-date) - (match-string 1 old-date)))) - (cond - ((equal arg '(4)) - (progn - (when (and old-date org-log-reschedule) - (org-add-log-setup 'delschedule nil old-date 'findpos - org-log-reschedule)) - (org-remove-timestamp-with-keyword org-scheduled-string) - (message "Item is no longer scheduled."))) - ((equal arg '(16)) - (save-excursion - (org-back-to-heading t) - (if (re-search-forward - org-scheduled-time-regexp - (save-excursion (outline-next-heading) (point)) t) - (let* ((rpl0 (match-string 1)) - (rpl (replace-regexp-in-string " -[0-9]+[hdwmy]" "" rpl0))) - (replace-match - (concat org-scheduled-string - " <" rpl - (format " -%dd" - (abs - (- (time-to-days - (save-match-data - (org-read-date nil t nil "Delay until" old-date-time))) - (time-to-days old-date-time)))) - ">") t t)) - (user-error "No scheduled information to update")))) - (t - (org-add-planning-info 'scheduled time 'closed) - (when (and old-date org-log-reschedule - (not (equal old-date - (substring org-last-inserted-timestamp 1 -1)))) - (org-add-log-setup 'reschedule nil old-date 'findpos - org-log-reschedule)) - (when repeater - (save-excursion - (org-back-to-heading t) - (when (re-search-forward (concat org-scheduled-string " " - org-last-inserted-timestamp) - (save-excursion - (outline-next-heading) (point)) t) - (goto-char (1- (match-end 0))) - (insert " " repeater) - (setq org-last-inserted-timestamp - (concat (substring org-last-inserted-timestamp 0 -1) - " " repeater - (substring org-last-inserted-timestamp -1)))))) - (message "Scheduled to %s" org-last-inserted-timestamp)))))) + (org-map-entries + (lambda () (org--deadline-or-schedule arg 'scheduled time)) + 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)))) + (org--deadline-or-schedule arg 'scheduled time))) (defun org-get-scheduled-time (pom &optional inherit) "Get the scheduled time as a time tuple, of a format suitable @@ -13167,24 +13512,36 @@ nil." (if (and (string-match "\\S-" (buffer-substring (point-at-bol) (point))) (equal (char-before) ?\ )) (backward-delete-char 1) - (if (string-match "^[ \t]*$" (buffer-substring - (point-at-bol) (point-at-eol))) - (delete-region (point-at-bol) - (min (point-max) (1+ (point-at-eol)))))))))) + (when (string-match "^[ \t]*$" (buffer-substring + (point-at-bol) (point-at-eol))) + (delete-region (point-at-bol) + (min (point-max) (1+ (point-at-eol)))))))))) (defvar org-time-was-given) ; dynamically scoped parameter (defvar org-end-time-was-given) ; dynamically scoped parameter -(defun org-add-planning-info (what &optional time &rest remove) - "Insert new timestamp with keyword in the line directly after the headline. -WHAT indicates what kind of time stamp to add. TIME indicates the time to use. -If non is given, the user is prompted for a date. -REMOVE indicates what kind of entries to remove. An old WHAT entry will also -be removed." - (interactive) - (let (org-time-was-given org-end-time-was-given ts - end default-time default-input) +(defun org-at-planning-p () + "Non-nil when point is on a planning info line." + ;; This is as accurate and faster than `org-element-at-point' since + ;; planning info location is fixed in the section. + (org-with-wide-buffer + (beginning-of-line) + (and (looking-at-p org-planning-line-re) + (eq (point) + (ignore-errors + (if (and (featurep 'org-inlinetask) (org-inlinetask-in-task-p)) + (org-back-to-heading t) + (org-with-limited-levels (org-back-to-heading t))) + (line-beginning-position 2)))))) +(defun org-add-planning-info (what &optional time &rest remove) + "Insert new timestamp with keyword in the planning line. +WHAT indicates what kind of time stamp to add. It is a symbol +among `closed', `deadline', `scheduled' and nil. TIME indicates +the time to use. If none is given, the user is prompted for +a date. REMOVE indicates what kind of entries to remove. An old +WHAT entry will also be removed." + (let (org-time-was-given org-end-time-was-given default-time default-input) (catch 'exit (when (and (memq what '(scheduled deadline)) (or (not time) @@ -13193,108 +13550,98 @@ be removed." ;; Try to get a default date/time from existing timestamp (save-excursion (org-back-to-heading t) - (setq end (save-excursion (outline-next-heading) (point))) - (when (re-search-forward (if (eq what 'scheduled) - org-scheduled-time-regexp - org-deadline-time-regexp) - end t) - (setq ts (match-string 1) - default-time - (apply 'encode-time (org-parse-time-string ts)) - default-input (and ts (org-get-compact-tod ts)))))) + (let ((end (save-excursion (outline-next-heading) (point))) ts) + (when (re-search-forward (if (eq what 'scheduled) + org-scheduled-time-regexp + org-deadline-time-regexp) + end t) + (setq ts (match-string 1) + default-time (apply 'encode-time (org-parse-time-string ts)) + default-input (and ts (org-get-compact-tod ts))))))) (when what (setq time (if (stringp time) - ;; This is a string (relative or absolute), set proper date - (apply 'encode-time + ;; This is a string (relative or absolute), set + ;; proper date. + (apply #'encode-time (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 default-time default-input))))) - (when (and org-insert-labeled-timestamps-at-point - (member what '(scheduled deadline))) - (insert - (if (eq what 'scheduled) org-scheduled-string org-deadline-string) " ") - (org-insert-time-stamp time org-time-was-given - nil nil nil (list org-end-time-was-given)) - (setq what nil)) - (save-excursion - (save-restriction - (let (col list elt ts buffer-invisibility-spec) - (org-back-to-heading t) - (looking-at (concat org-outline-regexp "\\( *\\)[^\r\n]*")) - (goto-char (match-end 1)) - (setq col (current-column)) - (goto-char (match-end 0)) - (if (eobp) (insert "\n") (forward-char 1)) - (when (and (not what) - (not (looking-at - (concat "[ \t]*" - org-keyword-time-not-clock-regexp)))) - ;; Nothing to add, nothing to remove...... :-) - (throw 'exit nil)) - (if (and (not (looking-at org-outline-regexp)) - (looking-at (concat "[^\r\n]*?" org-keyword-time-regexp - "[^\r\n]*")) - (not (equal (match-string 1) org-clock-string))) - (narrow-to-region (match-beginning 0) (match-end 0)) - (insert-before-markers "\n") - (backward-char 1) - (narrow-to-region (point) (point)) - (and org-adapt-indentation (org-indent-to-column col))) - ;; Check if we have to remove something. - (setq list (cons what remove)) - (while list - (setq elt (pop list)) - (when (or (and (eq elt 'scheduled) - (re-search-forward org-scheduled-time-regexp nil t)) - (and (eq elt 'deadline) - (re-search-forward org-deadline-time-regexp nil t)) - (and (eq elt 'closed) - (re-search-forward org-closed-time-regexp nil t))) - (replace-match "") - (if (looking-at "--+<[^>]+>") (replace-match "")))) - (and (looking-at "[ \t]+") (replace-match "")) - (and org-adapt-indentation (bolp) (org-indent-to-column col)) - (when what - (insert - (if (not (or (bolp) (eq (char-before) ?\ ))) " " "") - (cond ((eq what 'scheduled) org-scheduled-string) - ((eq what 'deadline) org-deadline-string) - ((eq what 'closed) org-closed-string)) - " ") - (setq ts (org-insert-time-stamp - time - (or org-time-was-given - (and (eq what 'closed) org-log-done-with-time)) - (eq what 'closed) - nil nil (list org-end-time-was-given))) - (insert - (if (not (or (bolp) (eq (char-before) ?\ ) - (memq (char-after) '(32 10)) - (eobp))) " " "")) - (end-of-line 1)) - (goto-char (point-min)) - (widen) - (if (and (looking-at "[ \t]*\n") - (equal (char-before) ?\n)) - (delete-region (1- (point)) (point-at-eol))) - ts)))))) - -(defvar org-log-note-marker (make-marker)) + (org-with-wide-buffer + (org-back-to-heading t) + (forward-line) + (unless (bolp) (insert "\n")) + (cond ((looking-at-p org-planning-line-re) + ;; Move to current indentation. + (skip-chars-forward " \t") + ;; Check if we have to remove something. + (dolist (type (if what (cons what remove) remove)) + (save-excursion + (when (re-search-forward + (cl-case type + (closed org-closed-time-regexp) + (deadline org-deadline-time-regexp) + (scheduled org-scheduled-time-regexp) + (otherwise + (error "Invalid planning type: %s" type))) + (line-end-position) t) + ;; Delete until next keyword or end of line. + (delete-region + (match-beginning 0) + (if (re-search-forward org-keyword-time-not-clock-regexp + (line-end-position) + t) + (match-beginning 0) + (line-end-position)))))) + ;; If there is nothing more to add and no more keyword + ;; is left, remove the line completely. + (if (and (looking-at-p "[ \t]*$") (not what)) + (delete-region (line-beginning-position) + (line-beginning-position 2)) + ;; If we removed last keyword, do not leave trailing + ;; white space at the end of line. + (let ((p (point))) + (save-excursion + (end-of-line) + (unless (= (skip-chars-backward " \t" p) 0) + (delete-region (point) (line-end-position))))))) + ((not what) (throw 'exit nil)) ; Nothing to do. + (t (insert-before-markers "\n") + (backward-char 1) + (when org-adapt-indentation + (indent-to-column (1+ (org-outline-level)))))) + (when what + ;; Insert planning keyword. + (insert (cl-case what + (closed org-closed-string) + (deadline org-deadline-string) + (scheduled org-scheduled-string) + (otherwise (error "Invalid planning type: %s" what))) + " ") + ;; Insert associated timestamp. + (let ((ts (org-insert-time-stamp + time + (or org-time-was-given + (and (eq what 'closed) org-log-done-with-time)) + (eq what 'closed) + nil nil (list org-end-time-was-given)))) + (unless (eolp) (insert " ")) + ts)))))) + +(defvar org-log-note-marker (make-marker) + "Marker pointing at the entry where the note is to be inserted.") (defvar org-log-note-purpose nil) (defvar org-log-note-state nil) (defvar org-log-note-previous-state nil) -(defvar org-log-note-how nil) (defvar org-log-note-extra nil) (defvar org-log-note-window-configuration nil) (defvar org-log-note-return-to (make-marker)) (defvar org-log-note-effective-time nil "Remembered current time so that dynamically scoped -`org-extend-today-until' affects tha timestamps in state change -log") +`org-extend-today-until' affects timestamps in state change log") (defvar org-log-post-message nil "Message to be displayed after a log note has been stored. @@ -13304,85 +13651,92 @@ The auto-repeater uses this.") "Add a note to the current entry. This is done in the same way as adding a state change note." (interactive) - (org-add-log-setup 'note nil nil 'findpos nil)) + (org-add-log-setup 'note)) -(defvar org-property-end-re) -(defun org-add-log-setup (&optional purpose state prev-state - findpos how extra) +(defun org-log-beginning (&optional create) + "Return expected start of log notes in current entry. +When optional argument CREATE is non-nil, the function creates +a drawer to store notes, if necessary. Returned position ignores +narrowing." + (org-with-wide-buffer + (let ((drawer (org-log-into-drawer))) + (cond + (drawer + (org-end-of-meta-data) + (let ((regexp (concat "^[ \t]*:" (regexp-quote drawer) ":[ \t]*$")) + (end (if (org-at-heading-p) (point) + (save-excursion (outline-next-heading) (point)))) + (case-fold-search t)) + (catch 'exit + ;; Try to find existing drawer. + (while (re-search-forward regexp end t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'drawer) + (let ((cend (org-element-property :contents-end element))) + (when (and (not org-log-states-order-reversed) cend) + (goto-char cend))) + (throw 'exit nil)))) + ;; No drawer found. Create one, if permitted. + (when create + (unless (bolp) (insert "\n")) + (let ((beg (point))) + (insert ":" drawer ":\n:END:\n") + (org-indent-region beg (point))) + (end-of-line -1))))) + (t + (org-end-of-meta-data org-log-state-notes-insert-after-drawers) + (skip-chars-forward " \t\n") + (beginning-of-line) + (unless org-log-states-order-reversed + (org-skip-over-state-notes) + (skip-chars-backward " \t\n") + (forward-line))))) + (if (bolp) (point) (line-beginning-position 2)))) + +(defun org-add-log-setup (&optional purpose state prev-state how extra) "Set up the post command hook to take a note. If this is about to TODO state change, the new state is expected in STATE. -When FINDPOS is non-nil, find the correct position for the note in -the current entry. If not, assume that it can be inserted at point. HOW is an indicator what kind of note should be created. EXTRA is additional text that will be inserted into the notes buffer." - (let* ((org-log-into-drawer (org-log-into-drawer)) - (drawer (cond ((stringp org-log-into-drawer) - org-log-into-drawer) - (org-log-into-drawer "LOGBOOK")))) - (save-restriction - (save-excursion - (when findpos - (org-back-to-heading t) - (narrow-to-region (point) (save-excursion - (outline-next-heading) (point))) - (looking-at (concat org-outline-regexp "\\( *\\)[^\r\n]*" - "\\(\n[^\r\n]*?" org-keyword-time-not-clock-regexp - "[^\r\n]*\\)?")) - (goto-char (match-end 0)) - (cond - (drawer - (if (re-search-forward (concat "^[ \t]*:" drawer ":[ \t]*$") - nil t) - (progn - (goto-char (match-end 0)) - (or org-log-states-order-reversed - (and (re-search-forward org-property-end-re nil t) - (goto-char (1- (match-beginning 0)))))) - (insert "\n:" drawer ":\n:END:") - (beginning-of-line 0) - (org-indent-line) - (beginning-of-line 2) - (org-indent-line) - (end-of-line 0))) - ((and org-log-state-notes-insert-after-drawers - (save-excursion - (forward-line) (looking-at org-drawer-regexp))) - (forward-line) - (while (looking-at org-drawer-regexp) - (goto-char (match-end 0)) - (re-search-forward org-property-end-re (point-max) t) - (forward-line)) - (forward-line -1))) - (unless org-log-states-order-reversed - (and (= (char-after) ?\n) (forward-char 1)) - (org-skip-over-state-notes) - (skip-chars-backward " \t\n\r"))) - (move-marker org-log-note-marker (point)) - (setq org-log-note-purpose purpose - org-log-note-state state - org-log-note-previous-state prev-state - org-log-note-how how - org-log-note-extra extra - org-log-note-effective-time (org-current-effective-time)) - (add-hook 'post-command-hook 'org-add-log-note 'append))))) + (move-marker org-log-note-marker (point)) + (setq org-log-note-purpose purpose + org-log-note-state state + org-log-note-previous-state prev-state + org-log-note-how how + org-log-note-extra extra + org-log-note-effective-time (org-current-effective-time)) + (add-hook 'post-command-hook 'org-add-log-note 'append)) (defun org-skip-over-state-notes () "Skip past the list of State notes in an entry." - (if (looking-at "\n[ \t]*- State") (forward-char 1)) (when (ignore-errors (goto-char (org-in-item-p))) (let* ((struct (org-list-struct)) - (prevs (org-list-prevs-alist struct))) - (while (looking-at "[ \t]*- State") + (prevs (org-list-prevs-alist struct)) + (regexp + (concat "[ \t]*- +" + (replace-regexp-in-string + " +" " +" + (org-replace-escapes + (regexp-quote (cdr (assq 'state org-log-note-headings))) + `(("%d" . ,org-ts-regexp-inactive) + ("%D" . ,org-ts-regexp) + ("%s" . "\"\\S-+\"") + ("%S" . "\"\\S-+\"") + ("%t" . ,org-ts-regexp-inactive) + ("%T" . ,org-ts-regexp) + ("%u" . ".*?") + ("%U" . ".*?"))))))) + (while (looking-at-p regexp) (goto-char (or (org-list-get-next-item (point) struct prevs) (org-list-get-item-end (point) struct))))))) -(defun org-add-log-note (&optional purpose) - "Pop up a window for taking a note, and add this note later at point." +(defun org-add-log-note (&optional _purpose) + "Pop up a window for taking a note, and add this note later." (remove-hook 'post-command-hook 'org-add-log-note) (setq org-log-note-window-configuration (current-window-configuration)) (delete-other-windows) (move-marker org-log-note-return-to (point)) - (org-pop-to-buffer-same-window (marker-buffer org-log-note-marker)) + (pop-to-buffer-same-window (marker-buffer org-log-note-marker)) (goto-char org-log-note-marker) (org-switch-to-buffer-other-window "*Org Note*") (erase-buffer) @@ -13411,23 +13765,23 @@ EXTRA is additional text that will be inserted into the notes buffer." ((eq org-log-note-purpose 'note) "this entry") (t (error "This should not happen"))))) - (if org-log-note-extra (insert org-log-note-extra)) - (org-set-local 'org-finish-function 'org-store-log-note) + (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))) (defvar org-note-abort nil) ; dynamically scoped (defun org-store-log-note () "Finish taking a log note, and insert it to where it belongs." - (let ((txt (buffer-string))) - (kill-buffer (current-buffer)) - (let ((note (cdr (assq org-log-note-purpose org-log-note-headings))) - lines ind bul) + (let ((txt (prog1 (buffer-string) + (kill-buffer))) + (note (cdr (assq org-log-note-purpose org-log-note-headings))) + lines) (while (string-match "\\`# .*\n[ \t\n]*" txt) (setq txt (replace-match "" t t txt))) - (if (string-match "\\s-+\\'" txt) - (setq txt (replace-match "" t t txt))) + (when (string-match "\\s-+\\'" txt) + (setq txt (replace-match "" t t txt))) (setq lines (org-split-string txt "\n")) - (when (and note (string-match "\\S-" note)) + (when (org-string-nw-p note) (setq note (org-replace-escapes note @@ -13445,74 +13799,83 @@ EXTRA is additional text that will be inserted into the notes buffer." (cons "%D" (format-time-string (org-time-stamp-format nil nil) org-log-note-effective-time)) - (cons "%s" (if org-log-note-state - (concat "\"" org-log-note-state "\"") - "")) - (cons "%S" (if org-log-note-previous-state - (concat "\"" org-log-note-previous-state "\"") - "\"\""))))) - (if lines (setq note (concat note " \\\\"))) + (cons "%s" (cond + ((not org-log-note-state) "") + ((string-match-p org-ts-regexp + org-log-note-state) + (format "\"[%s]\"" + (substring org-log-note-state 1 -1))) + (t (format "\"%s\"" org-log-note-state)))) + (cons "%S" + (cond + ((not org-log-note-previous-state) "") + ((string-match-p org-ts-regexp + org-log-note-previous-state) + (format "\"[%s]\"" + (substring + org-log-note-previous-state 1 -1))) + (t (format "\"%s\"" + org-log-note-previous-state))))))) + (when lines (setq note (concat note " \\\\"))) (push note lines)) - (when (or current-prefix-arg org-note-abort) - (when org-log-into-drawer - (org-remove-empty-drawer-at - (if (stringp org-log-into-drawer) org-log-into-drawer "LOGBOOK") - org-log-note-marker)) - (setq lines nil)) - (when lines + (when (and lines (not (or current-prefix-arg org-note-abort))) (with-current-buffer (marker-buffer org-log-note-marker) - (save-excursion - (goto-char org-log-note-marker) - (move-marker org-log-note-marker nil) - (end-of-line 1) - (if (not (bolp)) (let ((inhibit-read-only t)) (insert "\n"))) - (setq ind (save-excursion - (if (ignore-errors (goto-char (org-in-item-p))) - (let ((struct (org-list-struct))) - (org-list-get-ind - (org-list-get-top-point struct) struct)) - (skip-chars-backward " \r\t\n") - (cond - ((and (org-at-heading-p) - org-adapt-indentation) - (1+ (org-current-level))) - ((org-at-heading-p) 0) - (t (org-get-indentation)))))) - (setq bul (org-list-bullet-string "-")) - (org-indent-line-to ind) - (insert bul (pop lines)) - (let ((ind-body (+ (length bul) ind))) - (while lines - (insert "\n") - (org-indent-line-to ind-body) - (insert (pop lines)))) - (message "Note stored") - (org-back-to-heading t) - (org-cycle-hide-drawers 'children)) + (org-with-wide-buffer + ;; Find location for the new note. + (goto-char org-log-note-marker) + (set-marker org-log-note-marker nil) + ;; Note associated to a clock is to be located right after + ;; the clock. Do not move point. + (unless (eq org-log-note-purpose 'clock-out) + (goto-char (org-log-beginning t))) + ;; Make sure point is at the beginning of an empty line. + (cond ((not (bolp)) (let ((inhibit-read-only t)) (insert "\n"))) + ((looking-at "[ \t]*\\S-") (save-excursion (insert "\n")))) + ;; In an existing list, add a new item at the top level. + ;; Otherwise, indent line like a regular one. + (let ((itemp (org-in-item-p))) + (if itemp + (indent-line-to + (let ((struct (save-excursion + (goto-char itemp) (org-list-struct)))) + (org-list-get-ind (org-list-get-top-point struct) struct))) + (org-indent-line))) + (insert (org-list-bullet-string "-") (pop lines)) + (let ((ind (org-list-item-body-column (line-beginning-position)))) + (dolist (line lines) + (insert "\n") + (indent-line-to ind) + (insert line))) + (message "Note stored") + (org-back-to-heading t) + (org-cycle-hide-drawers 'children)) ;; 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'. (when (eq this-command 'org-agenda-todo) - (setcdr buffer-undo-list (cddr buffer-undo-list))))))) - ;; Don't add undo information when called from `org-agenda-todo' + (setcdr buffer-undo-list (cddr buffer-undo-list)))))) + ;; Don't add undo information when called from `org-agenda-todo'. (let ((buffer-undo-list (eq this-command 'org-agenda-todo))) (set-window-configuration org-log-note-window-configuration) (with-current-buffer (marker-buffer org-log-note-return-to) (goto-char org-log-note-return-to)) (move-marker org-log-note-return-to nil) - (and org-log-post-message (message "%s" org-log-post-message)))) + (when org-log-post-message (message "%s" org-log-post-message)))) -(defun org-remove-empty-drawer-at (drawer pos) - "Remove an empty drawer DRAWER at position POS. +(defun org-remove-empty-drawer-at (pos) + "Remove an empty drawer at position POS. POS may also be a marker." (with-current-buffer (if (markerp pos) (marker-buffer pos) (current-buffer)) - (save-excursion - (save-restriction - (widen) - (goto-char pos) - (if (org-in-regexp - (concat "^[ \t]*:" drawer ":[ \t]*\n[ \t]*:END:[ \t]*\n?") 2) - (replace-match "")))))) + (org-with-wide-buffer + (goto-char pos) + (let ((drawer (org-element-at-point))) + (when (and (memq (org-element-type drawer) '(drawer property-drawer)) + (not (org-element-property :contents-begin drawer))) + (delete-region (org-element-property :begin drawer) + (progn (goto-char (org-element-property :end drawer)) + (skip-chars-backward " \r\t\n") + (forward-line) + (point)))))))) (defvar org-ts-type nil) (defun org-sparse-tree (&optional arg type) @@ -13533,47 +13896,45 @@ D Show deadlines and scheduled items between a date range." (interactive "P") (setq type (or type org-sparse-tree-default-date-type)) (setq org-ts-type type) - (message "Sparse tree: [/]regexp [t]odo [T]odo-kwd [m]atch [p]roperty - [d]eadlines [b]efore-date [a]fter-date [D]ates range - [c]ycle through date types: %s" - (case type + (message "Sparse tree: [r]egexp [t]odo [T]odo-kwd [m]atch [p]roperty + \[d]eadlines [b]efore-date [a]fter-date [D]ates range + \[c]ycle through date types: %s" + (cl-case type (all "all timestamps") (scheduled "only scheduled") (deadline "only deadline") (active "only active timestamps") (inactive "only inactive timestamps") - (scheduled-or-deadline "scheduled/deadline") (closed "with a closed time-stamp") (otherwise "scheduled/deadline"))) (let ((answer (read-char-exclusive))) - (case answer + (cl-case answer (?c (org-sparse-tree arg - (cadr (memq type '(scheduled-or-deadline all scheduled deadline active - inactive closed))))) - (?d (call-interactively #'org-check-deadlines)) - (?b (call-interactively #'org-check-before-date)) - (?a (call-interactively #'org-check-after-date)) - (?D (call-interactively #'org-check-dates-range)) - (?t (call-interactively #'org-show-todo-tree)) + (cadr + (memq type '(nil all scheduled deadline active inactive closed))))) + (?d (call-interactively 'org-check-deadlines)) + (?b (call-interactively 'org-check-before-date)) + (?a (call-interactively 'org-check-after-date)) + (?D (call-interactively 'org-check-dates-range)) + (?t (call-interactively 'org-show-todo-tree)) (?T (org-show-todo-tree '(4))) - (?m (call-interactively #'org-match-sparse-tree)) + (?m (call-interactively 'org-match-sparse-tree)) ((?p ?P) - (let* ((kwd (org-icompleting-read + (let* ((kwd (completing-read "Property: " (mapcar #'list (org-buffer-property-keys)))) - (value (org-icompleting-read + (value (completing-read "Value: " (mapcar #'list (org-property-values kwd))))) (unless (string-match "\\`{.*}\\'" value) (setq value (concat "\"" value "\""))) (org-match-sparse-tree arg (concat kwd "=" value)))) - ((?r ?R ?/) (call-interactively #'org-occur)) + ((?r ?R ?/) (call-interactively 'org-occur)) (otherwise (user-error "No such sparse tree command \"%c\"" answer))))) -(defvar org-occur-highlights nil +(defvar-local org-occur-highlights nil "List of overlays used for occur matches.") -(make-variable-buffer-local 'org-occur-highlights) -(defvar org-occur-parameters nil +(defvar-local org-occur-parameters nil "Parameters of the active org-occur calls. This is a list, each call to org-occur pushes as cons cell, containing the regular expression and the callback, onto the list. @@ -13583,18 +13944,21 @@ will only contain one set of parameters. When the highlights are removed (for example with `C-c C-c', or with the next edit (depending on `org-remove-highlights-with-change'), this variable is emptied as well.") -(make-variable-buffer-local 'org-occur-parameters) (defun org-occur (regexp &optional keep-previous callback) "Make a compact tree which shows all matches of REGEXP. -The tree will show the lines where the regexp matches, and all higher -headlines above the match. It will also show the heading after the match, -to make sure editing the matching entry is easy. -If KEEP-PREVIOUS is non-nil, highlighting and exposing done by a previous -call to `org-occur' will be kept, to allow stacking of calls to this -command. -If CALLBACK is non-nil, it is a function which is called to confirm -that the match should indeed be shown." + +The tree will show the lines where the regexp matches, and any other context +defined in `org-show-context-detail', which see. + +When optional argument KEEP-PREVIOUS is non-nil, highlighting and exposing +done by a previous call to `org-occur' will be kept, to allow stacking of +calls to this command. + +Optional argument CALLBACK can be a function of no argument. In this case, +it is called with point at the end of the match, match data being set +accordingly. Current match is shown only if the return value is non-nil. +The function must neither move point nor alter narrowing." (interactive "sRegexp: \nP") (when (equal regexp "") (user-error "Regexp cannot be empty")) @@ -13604,32 +13968,35 @@ that the match should indeed be shown." (let ((cnt 0)) (save-excursion (goto-char (point-min)) - (if (or (not keep-previous) ; do not want to keep - (not org-occur-highlights)) ; no previous matches - ;; hide everything - (org-overview)) - (while (re-search-forward regexp nil t) - (when (or (not callback) - (save-match-data (funcall callback))) - (setq cnt (1+ cnt)) - (when org-highlight-sparse-tree-matches - (org-highlight-new-match (match-beginning 0) (match-end 0))) - (org-show-context 'occur-tree)))) + (when (or (not keep-previous) ; do not want to keep + (not org-occur-highlights)) ; no previous matches + ;; hide everything + (org-overview)) + (let ((case-fold-search (if (eq org-occur-case-fold-search 'smart) + (isearch-no-upper-case-p regexp t) + org-occur-case-fold-search))) + (while (re-search-forward regexp nil t) + (when (or (not callback) + (save-match-data (funcall callback))) + (setq cnt (1+ cnt)) + (when org-highlight-sparse-tree-matches + (org-highlight-new-match (match-beginning 0) (match-end 0))) + (org-show-context 'occur-tree))))) (when org-remove-highlights-with-change - (org-add-hook 'before-change-functions 'org-remove-occur-highlights - nil 'local)) + (add-hook 'before-change-functions 'org-remove-occur-highlights + nil 'local)) (unless org-sparse-tree-open-archived-trees (org-hide-archived-subtrees (point-min) (point-max))) (run-hooks 'org-occur-hook) - (if (org-called-interactively-p 'interactive) - (message "%d match(es) for regexp %s" cnt regexp)) + (when (called-interactively-p 'interactive) + (message "%d match(es) for regexp %s" cnt regexp)) cnt)) -(defun org-occur-next-match (&optional n reset) +(defun org-occur-next-match (&optional n _reset) "Function for `next-error-function' to find sparse tree matches. N is the number of matches to move, when negative move backwards. -RESET is entirely ignored - this function always goes back to the -starting point when no match is found." +This function always goes back to the starting point when no +match is found." (let* ((limit (if (< n 0) (point-min) (point-max))) (search-func (if (< n 0) 'previous-single-char-property-change @@ -13641,7 +14008,7 @@ starting point when no match is found." (while (setq p1 (funcall search-func (point) 'org-type)) (when (equal p1 limit) (goto-char pos) - (error "No more matches")) + (user-error "No more matches")) (when (equal (get-char-property p1 'org-type) 'org-occur) (setq n (1- n)) (when (= n 0) @@ -13649,65 +14016,75 @@ starting point when no match is found." (throw 'exit (point)))) (goto-char p1)) (goto-char p1) - (error "No more matches")))) + (user-error "No more matches")))) (defun org-show-context (&optional key) "Make sure point and context are visible. -How much context is shown depends upon the variables -`org-show-hierarchy-above', `org-show-following-heading', -`org-show-entry-below' and `org-show-siblings'." - (let ((heading-p (org-at-heading-p t)) - (hierarchy-p (org-get-alist-option org-show-hierarchy-above key)) - (following-p (org-get-alist-option org-show-following-heading key)) - (entry-p (org-get-alist-option org-show-entry-below key)) - (siblings-p (org-get-alist-option org-show-siblings key))) - ;; Show heading or entry text - (if (and heading-p (not entry-p)) - (org-flag-heading nil) ; only show the heading - (and (or entry-p (outline-invisible-p) (org-invisible-p2)) - (org-show-hidden-entry))) ; show entire entry - (when following-p - ;; Show next sibling, or heading below text - (save-excursion - (and (if heading-p (org-goto-sibling) (outline-next-heading)) - (org-flag-heading nil)))) - (when siblings-p (org-show-siblings)) - (when hierarchy-p - ;; show all higher headings, possibly with siblings - (save-excursion - (while (and (condition-case nil - (progn (org-up-heading-all 1) t) - (error nil)) - (not (bobp))) - (org-flag-heading nil) - (when siblings-p (org-show-siblings))))))) +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-hierarchy-above' or `org-show-following-heading' -not t for the search context. + +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 double optional argument \\[universal-argument] \\[universal-argument], \ -go to the parent and show the -entire tree." + +With a \\[universal-argument] \\[universal-argument] prefix, \ +go to the parent and show the entire tree." (interactive "P") (run-hooks 'org-reveal-start-hook) - (let ((org-show-hierarchy-above t) - (org-show-following-heading t) - (org-show-siblings (if siblings t org-show-siblings))) - (org-show-context nil)) - (when (equal siblings '(16)) - (save-excursion - (when (org-up-heading-safe) - (org-show-subtree) - (run-hook-with-args 'org-cycle-hook 'subtree))))) + (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." @@ -13716,13 +14093,13 @@ entire tree." (overlay-put ov 'org-type 'org-occur) (push ov org-occur-highlights))) -(defun org-remove-occur-highlights (&optional beg end noremove) +(defun org-remove-occur-highlights (&optional _beg _end noremove) "Remove the occur highlights from the buffer. BEG and END are ignored. If NOREMOVE is nil, remove this function from the `before-change-functions' in the current buffer." (interactive) (unless org-inhibit-highlight-removal - (mapc 'delete-overlay org-occur-highlights) + (mapc #'delete-overlay org-occur-highlights) (setq org-occur-highlights nil) (setq org-occur-parameters nil) (unless noremove @@ -13746,89 +14123,88 @@ 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." (interactive "P") (if (equal action '(4)) (org-show-priority) - (unless org-enable-priority-commands - (user-error "Priority commands are disabled")) - (setq action (or action 'set)) - (let (current new news have remove) - (save-excursion - (org-back-to-heading t) - (if (looking-at org-priority-regexp) + (unless org-enable-priority-commands + (user-error "Priority commands are disabled")) + (setq action (or action 'set)) + (let (current new news have remove) + (save-excursion + (org-back-to-heading t) + (when (looking-at org-priority-regexp) (setq current (string-to-char (match-string 2)) have t)) - (cond - ((eq action 'remove) - (setq remove t new ?\ )) - ((or (eq action 'set) - (if (featurep 'xemacs) (characterp action) (integerp action))) - (if (not (eq action 'set)) - (setq new action) - (message "Priority %c-%c, SPC to remove: " - org-highest-priority org-lowest-priority) - (save-match-data - (setq new (read-char-exclusive)))) - (if (and (= (upcase org-highest-priority) org-highest-priority) - (= (upcase org-lowest-priority) org-lowest-priority)) + (cond + ((eq action 'remove) + (setq remove t new ?\ )) + ((or (eq action 'set) + (integerp action)) + (if (not (eq action 'set)) + (setq new action) + (message "Priority %c-%c, SPC to remove: " + org-highest-priority org-lowest-priority) + (save-match-data + (setq new (read-char-exclusive)))) + (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)) - ((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)))) - ((eq action 'up) - (setq new (if have - (1- current) ; normal cycling - ;; last priority was empty - (if (eq last-command this-command) - org-lowest-priority ; wrap around empty to lowest - ;; default - (if org-priority-start-cycle-with-default - org-default-priority - (1- org-default-priority)))))) - ((eq action 'down) - (setq new (if have - (1+ current) ; normal cycling - ;; last priority was empty - (if (eq last-command this-command) - org-highest-priority ; wrap around empty to highest - ;; default - (if org-priority-start-cycle-with-default - org-default-priority - (1+ org-default-priority)))))) - (t (user-error "Invalid action"))) - (if (or (< (upcase new) org-highest-priority) - (> (upcase new) org-lowest-priority)) + (cond ((equal new ?\ ) (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)))) + ((eq action 'up) + (setq new (if have + (1- current) ; normal cycling + ;; last priority was empty + (if (eq last-command this-command) + org-lowest-priority ; wrap around empty to lowest + ;; default + (if org-priority-start-cycle-with-default + org-default-priority + (1- org-default-priority)))))) + ((eq action 'down) + (setq new (if have + (1+ current) ; normal cycling + ;; last priority was empty + (if (eq last-command this-command) + org-highest-priority ; wrap around empty to highest + ;; default + (if org-priority-start-cycle-with-default + org-default-priority + (1+ org-default-priority)))))) + (t (user-error "Invalid action"))) + (when (or (< (upcase new) org-highest-priority) + (> (upcase new) org-lowest-priority)) (if (and (memq action '(up down)) (not have) (not (eq last-command this-command))) - ;; `new' is from default priority + ;; `new' is from default priority (error "The default can not be set, see `org-default-priority' why") - ;; normal cycling: `new' is beyond highest/lowest priority - ;; and is wrapped around to the empty priority + ;; normal cycling: `new' is beyond highest/lowest priority + ;; and is wrapped around to the empty priority (setq remove t))) - (setq news (format "%c" new)) - (if have + (setq news (format "%c" new)) + (if have + (if remove + (replace-match "" t t nil 1) + (replace-match news t t nil 2)) (if remove - (replace-match "" t t nil 1) - (replace-match news t t nil 2)) - (if remove - (user-error "No priority cookie found in line") - (let ((case-fold-search nil)) - (looking-at org-todo-line-regexp)) - (if (match-end 2) - (progn - (goto-char (match-end 2)) - (insert " [#" news "]")) - (goto-char (match-beginning 3)) - (insert "[#" news "] ")))) - (org-preserve-lc (org-set-tags nil 'align))) - (if remove - (message "Priority removed") - (message "Priority of current item set to %s" news))))) + (user-error "No priority cookie found in line") + (let ((case-fold-search nil)) (looking-at org-todo-line-regexp)) + (if (match-end 2) + (progn + (goto-char (match-end 2)) + (insert " [#" news "]")) + (goto-char (match-beginning 3)) + (insert "[#" news "] ")))) + (org-set-tags nil 'align)) + (if remove + (message "Priority removed") + (message "Priority of current item set to %s" news))))) (defun org-show-priority () "Show the priority of the current item. @@ -13863,6 +14239,7 @@ Can be set by the action argument to `org-scan-tags' and `org-map-entries'.") (defvar org-scanner-tags nil "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. This is for internal dynamical scoping only. @@ -13874,6 +14251,8 @@ obtain a list of properties. Building the tags list for each entry in such a file becomes an N^2 operation - but with this variable set, it scales as N.") +(defvar org--matcher-tags-todo-only nil) + (defun org-scan-tags (action matcher todo-only &optional start-level) "Scan headline tags with inheritance and produce output ACTION. @@ -13882,11 +14261,14 @@ or `agenda' to produce an entry list for an agenda view. It can also be a Lisp form or a function that should be called at each matched headline, in this case the return value is a list of all return values from these calls. -MATCHER is a Lisp form to be evaluated, testing if a given set of tags -qualifies a headline for inclusion. When TODO-ONLY is non-nil, -only lines with a not-done TODO keyword are included in the output. -This should be the same variable that was scoped into -and set by `org-make-tags-matcher' when it constructed MATCHER. +MATCHER is a function accepting three arguments, returning +a non-nil value whenever a given set of tags qualifies a headline +for inclusion. See `org-make-tags-matcher' for more information. +As a special case, it can also be set to t (respectively nil) in +order to match all (respectively none) headline. + +When TODO-ONLY is non-nil, only lines with a not-done TODO +keyword are included in the output. START-LEVEL can be a string with asterisks, reducing the scope to headlines matching this string." @@ -13897,8 +14279,8 @@ headlines matching this string." (concat "\\*\\{" (number-to-string start-level) "\\} ") org-outline-regexp) " *\\(\\<\\(" - (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") - (org-re "\\)\\>\\)? *\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$"))) + (mapconcat #'regexp-quote org-todo-keywords-1 "\\|") + "\\)\\>\\)? *\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$")) (props (list 'face 'default 'done-face 'org-agenda-done 'undone-face 'default @@ -13915,8 +14297,9 @@ headlines matching this string." lspos tags tags-list (tags-alist (list (cons 0 org-file-tags))) (llast 0) rtn rtn1 level category i txt - todo marker entry priority) - (when (not (or (member action '(agenda sparse-tree)) (functionp action))) + todo marker entry priority + ts-date ts-date-type ts-date-pair) + (unless (or (member action '(agenda sparse-tree)) (functionp action)) (setq action (list 'lambda nil action))) (save-excursion (goto-char (point-min)) @@ -13927,11 +14310,17 @@ headlines matching this string." (re-search-forward re nil t)) (setq org-map-continue-from nil) (catch :skip - (setq todo (if (match-end 1) (org-match-string-no-properties 2)) - tags (if (match-end 4) (org-match-string-no-properties 4))) + (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))) (goto-char (setq lspos (match-beginning 0))) (setq level (org-reduced-level (org-outline-level)) category (org-get-category)) + (when (eq action 'agenda) + (setq ts-date-pair (org-agenda-entry-get-agenda-timestamp (point)) + ts-date (car ts-date-pair) + ts-date-type (cdr ts-date-pair))) (setq i llast llast level) ;; remove tag lists from same and sublevels (while (>= i level) @@ -13958,18 +14347,20 @@ headlines matching this string." (when (and tags org-use-tag-inheritance (or (not (eq t org-use-tag-inheritance)) org-tags-exclude-from-inheritance)) - ;; selective inheritance, remove uninherited ones + ;; Selective inheritance, remove uninherited ones. (setcdr (car tags-alist) (org-remove-uninherited-tags (cdar tags-alist)))) (when (and ;; eval matcher only when the todo condition is OK (and (or (not todo-only) (member todo org-not-done-keywords)) - (let ((case-fold-search t) (org-trust-scanner-tags t)) - (eval matcher))) + (if (functionp matcher) + (let ((case-fold-search t) (org-trust-scanner-tags t)) + (funcall matcher todo tags-list level)) + matcher)) - ;; Call the skipper, but return t if it does not skip, - ;; so that the `and' form continues evaluating + ;; Call the skipper, but return t if it does not + ;; skip, so that the `and' form continues evaluating. (progn (unless (eq action 'sparse-tree) (org-agenda-skip)) t) @@ -13995,7 +14386,8 @@ headlines matching this string." (if (eq org-tags-match-list-sublevels 'indented) (make-string (1- level) ?.) "") (org-get-heading)) - level category + (make-string level ?\s) + category tags-list) priority (org-get-priority txt)) (goto-char lspos) @@ -14003,7 +14395,9 @@ headlines matching this string." (org-add-props txt props 'org-marker marker 'org-hd-marker marker 'org-category category 'todo-state todo - 'priority priority 'type "tagsmatch") + 'ts-date ts-date + 'priority priority + 'type (concat "tagsmatch" ts-date-type)) (push txt rtn)) ((functionp action) (setq org-map-continue-from nil) @@ -14048,13 +14442,19 @@ headlines matching this string." (defun org-match-sparse-tree (&optional todo-only match) "Create a sparse tree according to tags string MATCH. -MATCH can contain positive and negative selection of tags, like -\"+WORK+URGENT-WITHBOSS\". -If optional argument TODO-ONLY is non-nil, only select lines that are -also TODO lines." + +MATCH is a string with match syntax. It can contain a selection +of tags (\"+work+urgent-boss\"), properties (\"LEVEL>3\"), and +TODO keywords (\"TODO=\\\"WAITING\\\"\") or a combination of +those. See the manual for details. + +If optional argument TODO-ONLY is non-nil, only select lines that +are also TODO tasks." (interactive "P") (org-agenda-prepare-buffers (list (current-buffer))) - (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)) todo-only)) + (let ((org--matcher-tags-todo-only todo-only)) + (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)) + org--matcher-tags-todo-only))) (defalias 'org-tags-sparse-tree 'org-match-sparse-tree) @@ -14062,15 +14462,17 @@ also TODO lines." (defun org-cached-entry-get (pom property) (if (or (eq t org-use-property-inheritance) (and (stringp org-use-property-inheritance) - (string-match org-use-property-inheritance property)) + (let ((case-fold-search t)) + (string-match-p org-use-property-inheritance property))) (and (listp org-use-property-inheritance) - (member property org-use-property-inheritance))) - ;; Caching is not possible, check it directly + (member-ignore-case property org-use-property-inheritance))) + ;; Caching is not possible, check it directly. (org-entry-get pom property 'inherit) - ;; Get all properties, so that we can do complicated checks easily - (cdr (assoc property (or org-cached-props - (setq org-cached-props - (org-entry-properties pom))))))) + ;; Get all properties, so we can do complicated checks easily. + (cdr (assoc-string property + (or org-cached-props + (setq org-cached-props (org-entry-properties pom))) + t)))) (defun org-global-tags-completion-table (&optional files) "Return the list of all tags in all agenda buffer/files. @@ -14079,186 +14481,173 @@ instead of the agenda files." (save-excursion (org-uniquify (delq nil - (apply 'append + (apply #'append (mapcar (lambda (file) (set-buffer (find-file-noselect file)) - (append (org-get-buffer-tags) - (mapcar (lambda (x) (if (stringp (car-safe x)) - (list (car-safe x)) nil)) - org-tag-alist))) - (if (and files (car files)) - files + (mapcar (lambda (x) + (and (stringp (car-safe x)) + (list (car-safe x)))) + (or org-current-tag-alist (org-get-buffer-tags)))) + (if (car-safe files) files (org-agenda-files)))))))) (defun org-make-tags-matcher (match) "Create the TAGS/TODO matcher form for the selection string MATCH. -The variable `todo-only' is scoped dynamically into this function. -It will be set to t if the matcher restricts matching to TODO entries, -otherwise will not be touched. - -Returns a cons of the selection string MATCH and the constructed -lisp form implementing the matcher. The matcher is to be evaluated -at an Org entry, with point on the headline, and returns t if the -entry matches the selection string MATCH. The returned lisp form -references two variables with information about the entry, which -must be bound around the form's evaluation: todo, the TODO keyword -at the entry (or nil of none); and tags-list, the list of all tags -at the entry including inherited ones. Additionally, the category -of the entry (if any) must be specified as the text property -'org-category on the headline. - -See also `org-scan-tags'. -" - (declare (special todo-only)) - (unless (boundp 'todo-only) - (error "`org-make-tags-matcher' expects todo-only to be scoped in")) +Returns a cons of the selection string MATCH and a function +implementing the matcher. + +The matcher is to be called at an Org entry, with point on the +headline, and returns non-nil if the entry matches the selection +string MATCH. It must be called with three arguments: the TODO +keyword at the entry (or nil if none), the list of all tags at +the entry including inherited ones and the reduced level of the +headline. Additionally, the category of the entry, if any, must +be specified as the text property `org-category' on the headline. + +This function sets the variable `org--matcher-tags-todo-only' to +a non-nil value if the matcher restricts matching to TODO +entries, otherwise it is not touched. + +See also `org-scan-tags'." (unless match ;; Get a new match request, with completion against the global - ;; tags table and the local tags in current buffer + ;; tags table and the local tags in current buffer. (let ((org-last-tags-completion-table (org-uniquify (delq nil (append (org-get-buffer-tags) (org-global-tags-completion-table)))))) - (setq match (org-completing-read-no-i - "Match: " 'org-tags-completion-function nil nil nil - 'org-tags-history)))) + (setq match + (completing-read + "Match: " + 'org-tags-completion-function nil nil nil 'org-tags-history)))) - ;; Parse the string and create a lisp form (let ((match0 match) - (re (org-re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)\\([<>=]\\{1,2\\}\\)\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)\\|[[:alnum:]_@#%]+\\)")) - minus tag mm - tagsmatch todomatch tagsmatcher todomatcher kwd matcher - orterms orlist re-p str-p level-p level-op time-p - prop-p pn pv po gv rest (start 0) (ss 0)) - ;; Expand group tags + (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)\\([<>=]\\{1,2\\}\\)\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)\\|[[:alnum:]_@#%]+\\)") + (start 0) + tagsmatch todomatch tagsmatcher todomatcher) + + ;; Expand group tags. (setq match (org-tags-expand match)) ;; Check if there is a TODO part of this match, which would be the - ;; part after a "/". TO make sure that this slash is not part of - ;; a property value to be matched against, we also check that there - ;; is no " after that slash. - ;; First, find the last slash - (while (string-match "/+" match ss) - (setq start (match-beginning 0) ss (match-end 0))) + ;; part after a "/". To make sure that this slash is not part of + ;; a property value to be matched against, we also check that + ;; there is no / after that slash. First, find the last slash. + (let ((s 0)) + (while (string-match "/+" match s) + (setq start (match-beginning 0)) + (setq s (match-end 0)))) (if (and (string-match "/+" match start) - (not (save-match-data (string-match "\"" match start)))) - ;; match contains also a todo-matching request + (not (string-match-p "\"" match start))) + ;; Match contains also a TODO-matching request. (progn - (setq tagsmatch (substring match 0 (match-beginning 0)) - todomatch (substring match (match-end 0))) - (if (string-match "^!" todomatch) - (setq todo-only t todomatch (substring todomatch 1))) - (if (string-match "^\\s-*$" todomatch) - (setq todomatch nil))) - ;; only matching tags - (setq tagsmatch match todomatch nil)) - - ;; Make the tags matcher - (if (or (not tagsmatch) (not (string-match "\\S-" tagsmatch))) - (setq tagsmatcher t) - (setq orterms (org-split-string tagsmatch "|") orlist nil) - (dolist (term orterms) - (while (and (equal (substring term -1) "\\") orterms) - (setq term (concat term "|" (pop orterms)))) ; repair bad split - (while (string-match re term) - (setq rest (substring term (match-end 0)) - minus (and (match-end 1) - (equal (match-string 1 term) "-")) - tag (save-match-data (replace-regexp-in-string - "\\\\-" "-" - (match-string 2 term))) - re-p (equal (string-to-char tag) ?{) - level-p (match-end 4) - prop-p (match-end 5) - mm (cond - (re-p `(org-match-any-p ,(substring tag 1 -1) tags-list)) - (level-p - (setq level-op (org-op-to-function (match-string 3 term))) - `(,level-op level ,(string-to-number - (match-string 4 term)))) - (prop-p - (setq pn (match-string 5 term) - po (match-string 6 term) - pv (match-string 7 term) - re-p (equal (string-to-char pv) ?{) - str-p (equal (string-to-char pv) ?\") - time-p (save-match-data - (string-match "^\"[[<].*[]>]\"$" pv)) - pv (if (or re-p str-p) (substring pv 1 -1) pv)) - (if time-p (setq pv (org-matcher-time pv))) - (setq po (org-op-to-function po (if time-p 'time str-p))) - (cond - ((equal pn "CATEGORY") - (setq gv '(get-text-property (point) 'org-category))) - ((equal pn "TODO") - (setq gv 'todo)) - (t - (setq gv `(org-cached-entry-get nil ,pn)))) - (if re-p - (if (eq po 'org<>) - `(not (string-match ,pv (or ,gv ""))) - `(string-match ,pv (or ,gv ""))) - (if str-p - `(,po (or ,gv "") ,pv) - `(,po (string-to-number (or ,gv "")) - ,(string-to-number pv) )))) - (t `(member ,tag tags-list))) - mm (if minus (list 'not mm) mm) - term rest) - (push mm tagsmatcher)) - (push (if (> (length tagsmatcher) 1) - (cons 'and tagsmatcher) - (car tagsmatcher)) - orlist) - (setq tagsmatcher nil)) - (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist))) - (setq tagsmatcher - (list 'progn '(setq org-cached-props nil) tagsmatcher))) - ;; Make the todo matcher - (if (or (not todomatch) (not (string-match "\\S-" todomatch))) - (setq todomatcher t) - (setq orterms (org-split-string todomatch "|") orlist nil) - (dolist (term orterms) - (while (string-match re term) - (setq minus (and (match-end 1) - (equal (match-string 1 term) "-")) - kwd (match-string 2 term) - re-p (equal (string-to-char kwd) ?{) - term (substring term (match-end 0)) - mm (if re-p - `(string-match ,(substring kwd 1 -1) todo) - (list 'equal 'todo kwd)) - mm (if minus (list 'not mm) mm)) - (push mm todomatcher)) - (push (if (> (length todomatcher) 1) - (cons 'and todomatcher) - (car todomatcher)) - orlist) - (setq todomatcher nil)) - (setq todomatcher (if (> (length orlist) 1) - (cons 'or orlist) (car orlist)))) - - ;; Return the string and lisp forms of the matcher - (setq matcher (if todomatcher - (list 'and tagsmatcher todomatcher) - tagsmatcher)) - (when todo-only - (setq matcher (list 'and '(member todo org-not-done-keywords) - matcher))) - (cons match0 matcher))) - -(defun org-tags-expand (match &optional single-as-list downcased) + (setq tagsmatch (substring match 0 (match-beginning 0))) + (setq todomatch (substring match (match-end 0))) + (when (string-prefix-p "!" todomatch) + (setq org--matcher-tags-todo-only t) + (setq todomatch (substring todomatch 1))) + (when (string-match "\\`\\s-*\\'" todomatch) + (setq todomatch nil))) + ;; Only matching tags. + (setq tagsmatch match) + (setq todomatch nil)) + + ;; Make the tags matcher. + (when (org-string-nw-p tagsmatch) + (let ((orlist nil) + (orterms (org-split-string tagsmatch "|")) + term) + (while (setq term (pop orterms)) + (while (and (equal (substring term -1) "\\") orterms) + (setq term (concat term "|" (pop orterms)))) ;repair bad split. + (while (string-match re term) + (let* ((rest (substring term (match-end 0))) + (minus (and (match-end 1) + (equal (match-string 1 term) "-"))) + (tag (save-match-data + (replace-regexp-in-string + "\\\\-" "-" (match-string 2 term)))) + (regexp (eq (string-to-char tag) ?{)) + (levelp (match-end 4)) + (propp (match-end 5)) + (mm + (cond + (regexp `(org-match-any-p ,(substring tag 1 -1) tags-list)) + (levelp + `(,(org-op-to-function (match-string 3 term)) + level + ,(string-to-number (match-string 4 term)))) + (propp + (let* ((gv (pcase (upcase (match-string 5 term)) + ("CATEGORY" + '(get-text-property (point) 'org-category)) + ("TODO" 'todo) + (p `(org-cached-entry-get nil ,p)))) + (pv (match-string 7 term)) + (regexp (eq (string-to-char pv) ?{)) + (strp (eq (string-to-char pv) ?\")) + (timep (string-match-p "^\"[[<].*[]>]\"$" pv)) + (po (org-op-to-function (match-string 6 term) + (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<>)) + `(not (string-match ,pv (or ,gv "")))) + (regexp `(string-match ,pv (or ,gv ""))) + (strp `(,po (or ,gv "") ,pv)) + (t + `(,po + (string-to-number (or ,gv "")) + ,(string-to-number pv)))))) + (t `(member ,tag tags-list))))) + (push (if minus `(not ,mm) mm) tagsmatcher) + (setq term rest))) + (push `(and ,@tagsmatcher) orlist) + (setq tagsmatcher nil)) + (setq tagsmatcher `(progn (setq org-cached-props nil) (or ,@orlist))))) + + ;; Make the TODO matcher. + (when (org-string-nw-p todomatch) + (let ((orlist nil)) + (dolist (term (org-split-string todomatch "|")) + (while (string-match re term) + (let* ((minus (and (match-end 1) + (equal (match-string 1 term) "-"))) + (kwd (match-string 2 term)) + (regexp (eq (string-to-char kwd) ?{)) + (mm (if regexp `(string-match ,(substring kwd 1 -1) todo) + `(equal todo ,kwd)))) + (push (if minus `(not ,mm) mm) todomatcher)) + (setq term (substring term (match-end 0)))) + (push (if (> (length todomatcher) 1) + (cons 'and todomatcher) + (car todomatcher)) + orlist) + (setq todomatcher nil)) + (setq todomatcher (cons 'or orlist)))) + + ;; Return the string and function of the matcher. If no + ;; tags-specific or todo-specific matcher exists, match + ;; everything. + (let ((matcher (if (and tagsmatcher todomatcher) + `(and ,tagsmatcher ,todomatcher) + (or tagsmatcher todomatcher t)))) + (when org--matcher-tags-todo-only + (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) "Expand group tags in MATCH. This replaces every group tag in MATCH with a regexp tag search. For example, a group tag \"Work\" defined as { Work : Lab Conf } will be replaced like this: - Work => {\\(?:Work\\|Lab\\|Conf\\)} - +Work => +{\\(?:Work\\|Lab\\|Conf\\)} - -Work => -{\\(?:Work\\|Lab\\|Conf\\)} + Work => {\\<\\(?:Work\\|Lab\\|Conf\\)\\>} + +Work => +{\\<\\(?:Work\\|Lab\\|Conf\\)\\>} + -Work => -{\\<\\(?:Work\\|Lab\\|Conf\\)\\>} Replacing by a regexp preserves the structure of the match. E.g., this expansion @@ -14268,6 +14657,12 @@ E.g., this expansion will match anything tagged with \"Lab\" and \"Home\", or tagged 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@.+} } +will be replaced like this: + + Proj => {\\<\\(?:Proj\\)\\>\\|P@.+} + 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. @@ -14276,34 +14671,113 @@ When DOWNCASE is non-nil, expand downcased TAGS." (if org-group-tags (let* ((case-fold-search t) (stable org-mode-syntax-table) - (tal (or org-tag-groups-alist-for-agenda - org-tag-groups-alist)) - (tal (if downcased - (mapcar (lambda(tg) (mapcar 'downcase tg)) tal) tal)) - (tml (mapcar 'car tal)) - (rtnmatch match) rpl) - ;; @ and _ are allowed as word-components in tags + (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) + ;; @ and _ are allowed as word-components in tags. (modify-syntax-entry ?@ "w" stable) (modify-syntax-entry ?_ "w" stable) - (while (and tml + ;; 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 tml) "\\>\\)") - rtnmatch))) - (let* ((dir (match-string 1 rtnmatch)) - (tag (match-string 2 rtnmatch)) + (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))) - (setq tml (delete tag tml)) - (when (not (get-text-property 0 'grouptag (match-string 2 rtnmatch))) - (setq rpl (append (org-uniquify rpl) (assoc tag tal))) - (setq rpl (concat dir "{\\<" (regexp-opt rpl) "\\>}")) - (if (stringp rpl) (org-add-props rpl '(grouptag t))) - (setq rtnmatch (replace-match rpl t t rtnmatch))))) + (unless (or (get-text-property 0 'grouptag (match-string 2 return-match)) + (member tag work-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 - (or (reverse rpl) (list rtnmatch)) - rtnmatch)) - (if single-as-list (list (if downcased (downcase match) match)) + (if tags-in-group tags-in-group (list return-match)) + return-match)) + (if single-as-list + (list (if downcased (downcase match) match)) match))) (defun org-op-to-function (op &optional stringp) @@ -14371,7 +14845,7 @@ epoch to the beginning of today (00:00)." (defvar org-add-colon-after-tag-completion nil) ;; dynamically scoped param (defvar org-tags-overlay (make-overlay 1 1)) -(org-detach-overlay org-tags-overlay) +(delete-overlay org-tags-overlay) (defun org-get-local-tags-at (&optional pos) "Get a list of tags defined in the current headline." @@ -14405,10 +14879,9 @@ ignore inherited ones." (org-back-to-heading t) (while (not (equal lastpos (point))) (setq lastpos (point)) - (when (looking-at - (org-re "[^\r\n]+?:\\([[:alnum:]_@#%:]+\\):[ \t]*$")) + (when (looking-at ".+?:\\([[:alnum:]_@#%:]+\\):[ \t]*$") (setq ltags (org-split-string - (org-match-string-no-properties 1) ":")) + (match-string-no-properties 1) ":")) (when parent (setq ltags (mapcar 'org-add-prop-inherited ltags))) (setq tags (append @@ -14417,7 +14890,7 @@ ignore inherited ones." ltags) tags))) (or org-use-tag-inheritance (throw 'done t)) - (if local (throw 'done t)) + (when local (throw 'done t)) (or (org-up-heading-safe) (error nil)) (setq parent t))) (error nil))))) @@ -14439,7 +14912,7 @@ If ONOFF is `on' or `off', don't toggle but set to this state." (let (res current) (save-excursion (org-back-to-heading t) - (if (re-search-forward (org-re "[ \t]:\\([[:alnum:]_@#%:]+\\):[ \t]*$") + (if (re-search-forward "[ \t]:\\([[:alnum:]_@#%:]+\\):[ \t]*$" (point-at-eol) t) (progn (setq current (match-string 1)) @@ -14465,29 +14938,24 @@ If ONOFF is `on' or `off', don't toggle but set to this state." (run-hooks 'org-after-tags-change-hook)) res)) -(defun org-align-tags-here (to-col) - ;; Assumes that this is a headline - "Align tags on the current headline to TO-COL." - (let ((pos (point)) (col (current-column)) ncol tags-l p) - (beginning-of-line 1) - (if (and (looking-at (org-re ".*?\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")) - (< pos (match-beginning 2))) - (progn - (setq tags-l (- (match-end 2) (match-beginning 2))) - (goto-char (match-beginning 1)) - (insert " ") - (delete-region (point) (1+ (match-beginning 2))) - (setq ncol (max (current-column) - (1+ col) - (if (> to-col 0) - to-col - (- (abs to-col) tags-l)))) - (setq p (point)) - (insert (make-string (- ncol (current-column)) ?\ )) - (setq ncol (current-column)) - (when indent-tabs-mode (tabify p (point-at-eol))) - (org-move-to-column (min ncol col))) - (goto-char pos)))) +(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." @@ -14517,7 +14985,8 @@ If DATA is nil or the empty string, any tags will be removed." (when data (save-excursion (org-back-to-heading t) - (when (looking-at org-complex-heading-regexp) + (when (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp)) (if (match-end 5) (progn (goto-char (match-beginning 5)) @@ -14528,11 +14997,11 @@ If DATA is nil or the empty string, any tags will be removed." (insert " " data) (org-set-tags nil 'align))) (beginning-of-line 1) - (if (looking-at ".*?\\([ \t]+\\)$") - (delete-region (match-beginning 1) (match-end 1)))))) + (when (looking-at ".*?\\([ \t]+\\)$") + (delete-region (match-beginning 1) (match-end 1)))))) (defun org-align-all-tags () - "Align the tags i all headings." + "Align the tags in all headings." (interactive) (save-excursion (or (ignore-errors (org-back-to-heading t)) @@ -14549,106 +15018,124 @@ 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 (if (outline-invisible-p) (org-end-of-subtree nil t)))) - (let* ((re org-outline-regexp-bol) - (current (unless arg (org-get-tags-string))) - (col (current-column)) - (org-setting-tags t) - table current-tags inherited-tags ; computed below when needed - tags p0 c0 c1 rpl di tc 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)) - (let ((buffer-invisibility-spec (org-inhibit-invisibility))) - (while (re-search-forward re nil t) - (org-set-tags nil t) - (end-of-line 1))) - (message "All tags realigned to column %d" org-tags-column)) - (if just-align - (setq tags current) - ;; Get a new set of tags from the user - (save-excursion - (setq table (append org-tag-persistent-alist - (or org-tag-alist (org-get-buffer-tags)) - (and - org-complete-tags-always-offer-all-agenda-tags - (org-global-tags-completion-table - (org-agenda-files)))) - org-last-tags-completion-table table - current-tags (org-split-string current ":") - inherited-tags (nreverse - (nthcdr (length current-tags) - (nreverse (org-get-tags-at)))) - tags - (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 - (if org-fast-tag-selection-include-todo - org-todo-key-alist)) - (let ((org-add-colon-after-tag-completion (< 1 (length table)))) - (org-trim - (org-icompleting-read "Tags: " - 'org-tags-completion-function - nil nil current 'org-tags-history)))))) - (while (string-match "[-+&]+" tags) - ;; No boolean logic, just a list - (setq tags (replace-match ":" t t tags)))) - - (setq tags (replace-regexp-in-string "[,]" ":" tags)) - - (if org-tags-sort-function - (setq tags (mapconcat 'identity - (sort (org-split-string - tags (org-re "[^[:alnum:]_@#%]+")) - org-tags-sort-function) ":"))) - - (if (string-match "\\`[\t ]*\\'" tags) - (setq tags "") - (unless (string-match ":$" tags) (setq tags (concat tags ":"))) - (unless (string-match "^:" tags) (setq tags (concat ":" tags)))) - - ;; Insert new tags at the correct column - (beginning-of-line 1) - (setq level (or (and (looking-at org-outline-regexp) - (- (match-end 0) (point) 1)) - 1)) - (cond - ((and (equal current "") (equal tags ""))) - ((re-search-forward - (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") - (point-at-eol) t) - (if (equal tags "") - (setq rpl "") - (goto-char (match-beginning 0)) - (setq c0 (current-column) - ;; compute offset for the case of org-indent-mode active - di (if (org-bound-and-true-p org-indent-mode) - (* (1- org-indent-indentation-per-level) (1- level)) - 0) - p0 (if (equal (char-before) ?*) (1+ (point)) (point)) - tc (+ org-tags-column (if (> org-tags-column 0) (- di) di)) - c1 (max (1+ c0) (if (> tc 0) tc (- (- tc) (length tags)))) - rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) - (replace-match rpl t t) - (and (not (featurep 'xemacs)) c0 indent-tabs-mode (tabify p0 (point))) - tags) - (t (error "Tags alignment failed"))) - (org-move-to-column col) - (unless just-align - (run-hooks 'org-after-tags-change-hook)))))) + (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* ((seen) + (table + (setq + org-last-tags-completion-table + ;; Uniquify tags in alists, yet preserve + ;; structure (i.e., keywords). + (delq nil + (mapcar + (lambda (pair) + (let ((head (car pair))) + (cond ((symbolp head) pair) + ((member head seen) nil) + (t (push head seen) + pair)))) + (append + (or org-current-tag-alist + (org-get-buffer-tags)) + (and + org-complete-tags-always-offer-all-agenda-tags + (org-global-tags-completion-table + (org-agenda-files)))))))) + (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)))))) (defun org-change-tag-in-region (beg end tag off) "Add or remove TAG for each entry in the region. -This works in the agenda, and also in an org-mode buffer." +This works in the agenda, and also in an Org buffer." (interactive (list (region-beginning) (region-end) (let ((org-last-tags-completion-table @@ -14657,37 +15144,37 @@ This works in the agenda, and also in an org-mode buffer." (delq nil (append (org-get-buffer-tags) (org-global-tags-completion-table)))) (org-global-tags-completion-table)))) - (org-icompleting-read + (completing-read "Tag: " 'org-tags-completion-function nil nil nil 'org-tags-history)) (progn (message "[s]et or [r]emove? ") (equal (read-char-exclusive) ?r)))) - (if (fboundp 'deactivate-mark) (deactivate-mark)) + (when (fboundp 'deactivate-mark) (deactivate-mark)) (let ((agendap (equal major-mode 'org-agenda-mode)) l1 l2 m buf pos newhead (cnt 0)) (goto-char end) (setq l2 (1- (org-current-line))) (goto-char beg) (setq l1 (org-current-line)) - (loop for l from l1 to l2 do - (org-goto-line l) - (setq m (get-text-property (point) 'org-hd-marker)) - (when (or (and (derived-mode-p 'org-mode) (org-at-heading-p)) - (and agendap m)) - (setq buf (if agendap (marker-buffer m) (current-buffer)) - pos (if agendap m (point))) - (with-current-buffer buf - (save-excursion - (save-restriction - (goto-char pos) - (setq cnt (1+ cnt)) - (org-toggle-tag tag (if off 'off 'on)) - (setq newhead (org-get-heading))))) - (and agendap (org-agenda-change-all-lines newhead m)))) + (cl-loop for l from l1 to l2 do + (org-goto-line l) + (setq m (get-text-property (point) 'org-hd-marker)) + (when (or (and (derived-mode-p 'org-mode) (org-at-heading-p)) + (and agendap m)) + (setq buf (if agendap (marker-buffer m) (current-buffer)) + pos (if agendap m (point))) + (with-current-buffer buf + (save-excursion + (save-restriction + (goto-char pos) + (setq cnt (1+ cnt)) + (org-toggle-tag tag (if off 'off 'on)) + (setq newhead (org-get-heading))))) + (and agendap (org-agenda-change-all-lines newhead m)))) (message "Tag :%s: %s in %d headings" tag (if off "removed" "set") cnt))) -(defun org-tags-completion-function (string predicate &optional flag) +(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) @@ -14698,12 +15185,12 @@ This works in the agenda, and also in an org-mode buffer." ((eq flag nil) ;; try completion (setq rtn (try-completion s2 ctable confirm)) - (if (stringp rtn) - (setq rtn - (concat s1 s2 (substring rtn (length s2)) - (if (and org-add-colon-after-tag-completion - (assoc rtn ctable)) - ":" "")))) + (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 @@ -14722,8 +15209,8 @@ Also insert END." (defun org-fast-tag-show-exit (flag) (save-excursion (org-goto-line 3) - (if (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) - (replace-match "")) + (when (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) + (replace-match "")) (when flag (end-of-line 1) (org-move-to-column (- (window-width) 19) t) @@ -14732,11 +15219,8 @@ 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 ":") ":"))) - (if (featurep 'xemacs) - (org-overlay-display org-tags-overlay (concat prefix s) - 'secondary-selection) - (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) - (org-overlay-display org-tags-overlay (concat prefix s))))) + (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) + (org-overlay-display org-tags-overlay (concat prefix s)))) (defvar org-last-tag-selection-key nil) (defun org-fast-tag-selection (current inherited table &optional todo-table) @@ -14759,15 +15243,14 @@ Returns the new tags string, or nil to not change the current settings." (ncol (/ (- (window-width) 4) fwidth)) (i-face 'org-done) (c-face 'org-todo) - tg cnt c char c1 c2 ntable tbl rtn + tg cnt e c char c1 c2 ntable tbl rtn ov-start ov-end ov-prefix (exit-after-next org-fast-tag-selection-single-key) (done-keywords org-done-keywords) - groups ingroup) + groups ingroup intaggroup) (save-excursion (beginning-of-line 1) - (if (looking-at - (org-re ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")) + (if (looking-at ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") (setq ov-start (match-beginning 1) ov-end (match-end 1) ov-prefix "") @@ -14788,32 +15271,41 @@ Returns the new tags string, or nil to not change the current settings." (set-window-buffer (split-window-vertically) (get-buffer-create " *Org tags*")) (org-switch-to-buffer-other-window " *Org tags*")) (erase-buffer) - (org-set-local 'org-done-keywords done-keywords) + (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) - (dolist (e tbl) + (while (setq e (pop tbl)) (cond - ((equal (car e) :startgroup) + ((eq (car e) :startgroup) (push '() groups) (setq ingroup t) - (when (not (= cnt 0)) + (unless (zerop cnt) (setq cnt 0) (insert "\n")) (insert (if (cdr e) (format "%s: " (cdr e)) "") "{ ")) - ((equal (car e) :endgroup) + ((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)) - (when (not (= cnt 0)) + (unless (zerop cnt) (setq cnt 0) (insert "\n") (setq e (car tbl)) (while (equal (car tbl) '(:newline)) (insert "\n") (setq tbl (cdr tbl))))) - ((equal e '(:grouptags)) nil) + ((equal e '(:grouptags)) (insert " : ")) (t (setq tg (copy-sequence (car e)) c2 nil) (if (cdr e) @@ -14827,27 +15319,27 @@ Returns the new tags string, or nil to not change the current settings." (setq char (1+ char))) (setq c2 c1)) (setq c (or c2 char))) - (if ingroup (push tg (car groups))) + (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)))) - (if (equal (caar tbl) :grouptags) - (org-add-props tg nil 'face 'org-tag-group)) - (if (and (= cnt 0) (not ingroup)) (insert " ")) + (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 (= (setq cnt (1+ cnt)) ncol) + (when (= (cl-incf cnt) ncol) (insert "\n") - (if ingroup (insert " ")) + (when (or ingroup intaggroup) (insert " ")) (setq cnt 0))))) (setq ntable (nreverse ntable)) (insert "\n") (goto-char (point-min)) - (if (not expert) (org-fit-window-to-buffer)) + (unless expert (org-fit-window-to-buffer)) (setq rtn (catch 'exit (while t @@ -14873,53 +15365,51 @@ Returns the new tags string, or nil to not change the current settings." (org-fit-window-to-buffer))) ((or (= c ?\C-g) (and (= c ?q) (not (rassoc c ntable)))) - (org-detach-overlay org-tags-overlay) + (delete-overlay org-tags-overlay) (setq quit-flag t)) ((= c ?\ ) (setq current nil) - (if exit-after-next (setq exit-after-next 'now))) + (when exit-after-next (setq exit-after-next 'now))) ((= c ?\t) (condition-case nil - (setq tg (org-icompleting-read + (setq tg (completing-read "Tag: " (or buffer-tags (with-current-buffer buf - (org-get-buffer-tags))))) + (setq buffer-tags + (org-get-buffer-tags)))))) (quit (setq tg ""))) (when (string-match "\\S-" tg) - (add-to-list 'buffer-tags (list tg)) + (cl-pushnew (list tg) buffer-tags :test #'equal) (if (member tg current) (setq current (delete tg current)) (push tg current))) - (if exit-after-next (setq exit-after-next 'now))) + (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))) - (if exit-after-next (setq exit-after-next 'now))) + (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)) - (loop for g in groups do - (if (member tg g) - (mapc (lambda (x) - (setq current (delete x current))) - g))) + (cl-loop for g in groups do + (when (member tg g) + (dolist (x g) (setq current (delete x current))))) (push tg current)) - (if exit-after-next (setq exit-after-next 'now)))) + (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)))))) - (if (eq exit-after-next 'now) (throw 'exit t)) + (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 - (org-re "\\[.\\] \\([[:alnum:]_@#%]+\\)") nil t) + (while (re-search-forward "\\[.\\] \\([[:alnum:]_@#%]+\\)" nil t) (setq tg (match-string 1)) (add-text-properties (match-beginning 1) (match-end 1) @@ -14929,7 +15419,7 @@ Returns the new tags string, or nil to not change the current settings." ((member tg inherited) i-face) (t (get-text-property (match-beginning 1) 'face)))))) (goto-char (point-min))))) - (org-detach-overlay org-tags-overlay) + (delete-overlay org-tags-overlay) (if rtn (mapconcat 'identity current ":") nil)))) @@ -14940,8 +15430,8 @@ Returns the new tags string, or nil to not change the current settings." (user-error "Not on a heading")) (save-excursion (beginning-of-line 1) - (if (looking-at (org-re ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")) - (org-match-string-no-properties 1) + (if (looking-at ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") + (match-string-no-properties 1) ""))) (defun org-get-tags () @@ -14950,19 +15440,20 @@ Returns the new tags string, or nil to not change the current settings." (defun org-get-buffer-tags () "Get a table of all tags used in the buffer, for completion." - (let (tags) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - (org-re "[ \t]:\\([[:alnum:]_@#%:]+\\):[ \t\r\n]") nil t) - (when (equal (char-after (point-at-bol 0)) ?*) - (mapc (lambda (x) (add-to-list 'tags x)) - (org-split-string (org-match-string-no-properties 1) ":"))))) - (mapc (lambda (s) (add-to-list 'tags s)) org-file-tags) - (mapcar 'list tags))) + (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)))))) ;;;; The mapping API +(defvar org-agenda-skip-comment-trees) +(defvar org-agenda-skip-function) (defun org-map-entries (func &optional match scope &rest skip) "Call FUNC at each headline selected by MATCH in SCOPE. @@ -15032,13 +15523,12 @@ a *different* entry, you cannot use these techniques." (car (org-delete-all '(comment archive) skip))) (org-tags-match-list-sublevels t) (start-level (eq scope 'region-start-level)) - matcher file res + matcher res org-todo-keywords-for-agenda org-done-keywords-for-agenda org-todo-keyword-alist-for-agenda - org-drawers-for-agenda org-tag-alist-for-agenda - todo-only) + org--matcher-tags-todo-only) (cond ((eq match t) (setq matcher t)) @@ -15071,7 +15561,9 @@ a *different* entry, you cannot use these techniques." (progn (org-agenda-prepare-buffers (and buffer-file-name (list buffer-file-name))) - (setq res (org-scan-tags func matcher todo-only start-level))) + (setq res + (org-scan-tags + func matcher org--matcher-tags-todo-only start-level))) ;; Get the right scope (cond ((and scope (listp scope) (symbolp (car scope))) @@ -15088,22 +15580,21 @@ a *different* entry, you cannot use these techniques." (org-agenda-prepare-buffers scope) (dolist (file scope) (with-current-buffer (org-find-base-buffer-visiting file) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (setq res (append res (org-scan-tags func matcher todo-only)))))))))) + (org-with-wide-buffer + (goto-char (point-min)) + (setq res + (append + res + (org-scan-tags + func matcher org--matcher-tags-todo-only))))))))) res))) -;;;; Properties - -;;; Setting and retrieving properties +;;; Properties API (defconst org-special-properties - '("TODO" "TAGS" "ALLTAGS" "DEADLINE" "SCHEDULED" "CLOCK" "CLOSED" "PRIORITY" - "TIMESTAMP" "TIMESTAMP_IA" "BLOCKED" "FILE" "CLOCKSUM" "CLOCKSUM_T") - "The special properties valid in Org-mode. - + '("ALLTAGS" "BLOCKED" "CLOCKSUM" "CLOCKSUM_T" "CLOSED" "DEADLINE" "FILE" + "ITEM" "PRIORITY" "SCHEDULED" "TAGS" "TIMESTAMP" "TIMESTAMP_IA" "TODO") + "The special properties valid in Org mode. These are properties that are not defined in the property drawer, but in some other way.") @@ -15112,59 +15603,86 @@ but in some other way.") "LOCATION" "LOGGING" "COLUMNS" "VISIBILITY" "TABLE_EXPORT_FORMAT" "TABLE_EXPORT_FILE" "EXPORT_OPTIONS" "EXPORT_TEXT" "EXPORT_FILE_NAME" - "EXPORT_TITLE" "EXPORT_AUTHOR" "EXPORT_DATE" + "EXPORT_TITLE" "EXPORT_AUTHOR" "EXPORT_DATE" "UNNUMBERED" "ORDERED" "NOBLOCKING" "COOKIE_DATA" "LOG_INTO_DRAWER" "REPEAT_TO_STATE" "CLOCK_MODELINE_TOTAL" "STYLE" "HTML_CONTAINER_CLASS") - "Some properties that are used by Org-mode for various purposes. + "Some properties that are used by Org mode for various purposes. Being in this list makes sure that they are offered for completion.") -(defconst org-property-start-re "^[ \t]*:PROPERTIES:[ \t]*$" - "Regular expression matching the first line of a property drawer.") - -(defconst org-property-end-re "^[ \t]*:END:[ \t]*$" - "Regular expression matching the last line of a property drawer.") - -(defconst org-clock-drawer-start-re "^[ \t]*:CLOCK:[ \t]*$" - "Regular expression matching the first line of a property drawer.") - -(defconst org-clock-drawer-end-re "^[ \t]*:END:[ \t]*$" - "Regular expression matching the first line of a property drawer.") - -(defconst org-property-drawer-re - (concat "\\(" org-property-start-re "\\)[^\000]*\\(" - org-property-end-re "\\)\n?") - "Matches an entire property drawer.") +(defun org--valid-property-p (property) + "Non nil when string PROPERTY is a valid property name." + (not + (or (equal property "") + (string-match-p "\\s-" property)))) + +(defun org--update-property-plist (key val props) + "Associate KEY to VAL in alist PROPS. +Modifications are made by side-effect. Return new alist." + (let* ((appending (string= (substring key -1) "+")) + (key (if appending (substring key 0 -1) key)) + (old (assoc-string key props t))) + (if (not old) (cons (cons key val) props) + (setcdr old (if appending (concat (cdr old) " " val) val)) + props))) + +(defun org-get-property-block (&optional beg force) + "Return the (beg . end) range of the body of the property drawer. +BEG is the beginning of the current subtree, or of the part +before the first headline. If it is not given, it will be found. +If the drawer does not exist, create it if FORCE is non-nil, or +return nil." + (org-with-wide-buffer + (when beg (goto-char beg)) + (unless (org-before-first-heading-p) + (let ((beg (cond (beg) + ((or (not (featurep 'org-inlinetask)) + (org-inlinetask-in-task-p)) + (org-back-to-heading t)) + (t (org-with-limited-levels (org-back-to-heading t)))))) + (forward-line) + (when (looking-at-p org-planning-line-re) (forward-line)) + (cond ((looking-at org-property-drawer-re) + (forward-line) + (cons (point) (progn (goto-char (match-end 0)) + (line-beginning-position)))) + (force + (goto-char beg) + (org-insert-property-drawer) + (let ((pos (save-excursion (search-forward ":END:") + (line-beginning-position)))) + (cons pos pos)))))))) -(defconst org-clock-drawer-re - (concat "\\(" org-clock-drawer-start-re "\\)[^\000]*\\(" - org-property-end-re "\\)\n?") - "Matches an entire clock drawer.") +(defun org-at-property-p () + "Non-nil when point is inside a property drawer. +See `org-property-re' for match data, if applicable." + (save-excursion + (beginning-of-line) + (and (looking-at org-property-re) + (let ((property-drawer (save-match-data (org-get-property-block)))) + (and property-drawer + (>= (point) (car property-drawer)) + (< (point) (cdr property-drawer))))))) (defun org-property-action () "Do an action on properties." (interactive) - (let (c) - (org-at-property-p) - (message "Property Action: [s]et [d]elete [D]elete globally [c]ompute") - (setq c (read-char-exclusive)) - (cond - ((equal c ?s) - (call-interactively 'org-set-property)) - ((equal c ?d) - (call-interactively 'org-delete-property)) - ((equal c ?D) - (call-interactively 'org-delete-property-globally)) - ((equal c ?c) - (call-interactively 'org-compute-property-at-point)) - (t (user-error "No such property action %c" c))))) + (unless (org-at-property-p) (user-error "Not at a property")) + (message "Property Action: [s]et [d]elete [D]elete globally [c]ompute") + (let ((c (read-char-exclusive))) + (cl-case c + (?s (call-interactively #'org-set-property)) + (?d (call-interactively #'org-delete-property)) + (?D (call-interactively #'org-delete-property-globally)) + (?c (call-interactively #'org-compute-property-at-point)) + (otherwise (user-error "No such property action %c" c))))) (defun org-inc-effort () "Increment the value of the effort property in the current entry." (interactive) (org-set-effort nil t)) -(defvar org-clock-effort) ;; Defined in org-clock.el -(defvar org-clock-current-task) ;; Defined in org-clock.el +(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) "Set the effort property of the current entry. With numerical prefix arg, use the nth allowed value, 0 stands for the @@ -15172,7 +15690,7 @@ With numerical prefix arg, use the nth allowed value, 0 stands for the When INCREMENT is non-nil, set the property to the next allowed value." (interactive "P") - (if (equal value 0) (setq value 10)) + (when (equal value 0) (setq value 10)) (let* ((completion-ignore-case t) (prop org-effort-property) (cur (org-entry-get nil prop)) @@ -15186,7 +15704,7 @@ When INCREMENT is non-nil, set the property to the next allowed value." (or (car (nth (1- value) allowed)) (car (org-last allowed)))) ((and allowed increment) - (or (caadr (member (list cur) allowed)) + (or (cl-caadr (member (list cur) allowed)) (user-error "Allowed effort values are not set"))) (allowed (message "Select 1-9,0, [RET%s]: %s" @@ -15196,231 +15714,295 @@ When INCREMENT is non-nil, set the property to the next allowed value." (if (equal rpl ?\r) cur (setq rpl (- rpl ?0)) - (if (equal rpl 0) (setq rpl 10)) + (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 - (let (org-completion-use-ido org-completion-use-iswitchb) - (org-completing-read - (concat "Effort " (if (and cur (string-match "\\S-" cur)) - (concat "[" cur "]") "") - ": ") - existing nil nil "" nil cur)))))) + (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)) - (save-excursion - (org-back-to-heading t) - (put-text-property (point-at-bol) (point-at-eol) 'org-effort val)) - (when (string= heading org-clock-current-task) - (setq org-clock-effort (get-text-property (point-at-bol) 'org-effort)) + (org-refresh-property + '((effort . identity) + (effort-minutes . org-duration-string-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)) (org-clock-update-mode-line)) (message "%s is now %s" prop val))) -(defun org-at-property-p () - "Is cursor inside a property drawer?" - (save-excursion - (when (equal 'node-property (car (org-element-at-point))) - (beginning-of-line 1) - (looking-at org-property-re)))) +(defun org-entry-properties (&optional pom which) + "Get all properties of the current entry. + +When POM is a buffer position, get all properties from the entry +there instead. + +This includes the TODO keyword, the tags, time strings for +deadline, scheduled, and clocking, and any additional properties +defined in the entry. -(defun org-get-property-block (&optional beg end force) - "Return the (beg . end) range of the body of the property drawer. -BEG and END are the beginning and end of the current subtree, or of -the part before the first headline. If they are not given, they will -be found. If the drawer does not exist and FORCE is non-nil, create -the drawer." - (catch 'exit - (save-excursion - (let* ((beg (or beg (and (org-before-first-heading-p) (point-min)) - (progn (org-back-to-heading t) (point)))) - (end (or end (and (not (outline-next-heading)) (point-max)) - (point)))) - (goto-char beg) - (if (re-search-forward org-property-start-re end t) - (setq beg (1+ (match-end 0))) - (if force - (save-excursion - (org-insert-property-drawer) - (setq end (progn (outline-next-heading) (point)))) - (throw 'exit nil)) - (goto-char beg) - (if (re-search-forward org-property-start-re end t) - (setq beg (1+ (match-end 0))))) - (if (re-search-forward org-property-end-re end t) - (setq end (match-beginning 0)) - (or force (throw 'exit nil)) - (goto-char beg) - (setq end beg) - (org-indent-line) - (insert ":END:\n")) - (cons beg end))))) - -(defun org-entry-properties (&optional pom which specific) - "Get all properties of the entry at point-or-marker POM. -This includes the TODO keyword, the tags, time strings for deadline, -scheduled, and clocking, and any additional properties defined in the -entry. The return value is an alist, keys may occur multiple times -if the property key was used several times. -POM may also be nil, in which case the current entry is used. If WHICH is nil or `all', get all properties. If WHICH is -`special' or `standard', only get that subclass. If WHICH -is a string only get exactly this property. SPECIFIC can be a string, the -specific property we are interested in. Specifying it can speed -things up because then unnecessary parsing is avoided." - (setq which (or which 'all)) - (org-with-wide-buffer - (org-with-point-at pom - (let ((clockstr (substring org-clock-string 0 -1)) - (excluded '("TODO" "TAGS" "ALLTAGS" "PRIORITY" "BLOCKED")) - (case-fold-search nil) - beg end range props sum-props key key1 value string clocksum clocksumt) - (when (and (derived-mode-p 'org-mode) - (ignore-errors (org-back-to-heading t))) - (setq beg (point)) - (setq sum-props (get-text-property (point) 'org-summaries)) - (setq clocksum (get-text-property (point) :org-clock-minutes) - clocksumt (get-text-property (point) :org-clock-minutes-today)) - (outline-next-heading) - (setq end (point)) - (when (memq which '(all special)) - ;; Get the special properties, like TODO and tags - (goto-char beg) - (when (and (or (not specific) (string= specific "TODO")) - (looking-at org-todo-line-regexp) (match-end 2)) - (push (cons "TODO" (org-match-string-no-properties 2)) props)) - (when (and (or (not specific) (string= specific "PRIORITY")) - (looking-at org-priority-regexp)) - (push (cons "PRIORITY" (org-match-string-no-properties 2)) props)) - (when (or (not specific) (string= specific "FILE")) - (push (cons "FILE" buffer-file-name) props)) - (when (and (or (not specific) (string= specific "TAGS")) - (setq value (org-get-tags-string)) - (string-match "\\S-" value)) - (push (cons "TAGS" value) props)) - (when (and (or (not specific) (string= specific "ALLTAGS")) - (setq value (org-get-tags-at))) - (push (cons "ALLTAGS" (concat ":" (mapconcat 'identity value ":") - ":")) - props)) - (when (or (not specific) (string= specific "BLOCKED")) - (push (cons "BLOCKED" (if (org-entry-blocked-p) "t" "")) props)) - (when (or (not specific) - (member specific - '("SCHEDULED" "DEADLINE" "CLOCK" "CLOSED" - "TIMESTAMP" "TIMESTAMP_IA"))) - (catch 'match - (while (and (re-search-forward org-maybe-keyword-time-regexp end t) - (not (text-property-any 0 (length (match-string 0)) - 'face 'font-lock-comment-face - (match-string 0)))) - (setq key (if (match-end 1) - (substring (org-match-string-no-properties 1) - 0 -1)) - string (if (equal key clockstr) - (org-trim - (buffer-substring-no-properties - (match-beginning 3) (goto-char - (point-at-eol)))) - (substring (org-match-string-no-properties 3) - 1 -1))) - ;; Get the correct property name from the key. This is - ;; necessary if the user has configured time keywords. - (setq key1 (concat key ":")) - (cond - ((not key) - (setq key - (if (= (char-after (match-beginning 3)) ?\[) - "TIMESTAMP_IA" "TIMESTAMP"))) - ((equal key1 org-scheduled-string) (setq key "SCHEDULED")) - ((equal key1 org-deadline-string) (setq key "DEADLINE")) - ((equal key1 org-closed-string) (setq key "CLOSED")) - ((equal key1 org-clock-string) (setq key "CLOCK"))) - (if (and specific (equal key specific) (not (equal key "CLOCK"))) - (progn - (push (cons key string) props) - ;; no need to search further if match is found - (throw 'match t)) - (when (or (equal key "CLOCK") (not (assoc key props))) - (push (cons key string) props))))))) - - (when (memq which '(all standard)) - ;; Get the standard properties, like :PROP: ... - (setq range (org-get-property-block beg end)) - (when range - (goto-char (car range)) - (while (re-search-forward org-property-re - (cdr range) t) - (setq key (org-match-string-no-properties 2) - value (org-trim (or (org-match-string-no-properties 3) ""))) - (unless (member key excluded) - (push (cons key (or value "")) props))))) - (if clocksum - (push (cons "CLOCKSUM" - (org-columns-number-to-string (/ (float clocksum) 60.) - 'add_times)) - props)) - (if clocksumt - (push (cons "CLOCKSUM_T" - (org-columns-number-to-string (/ (float clocksumt) 60.) - 'add_times)) - props)) - (unless (assoc "CATEGORY" props) - (push (cons "CATEGORY" (org-get-category)) props)) - (append sum-props (nreverse props))))))) +`special' or `standard', only get that subclass. If WHICH is +a string, only get that property. + +Return value is an alist. Keys are properties, as upcased +strings." + (org-with-point-at pom + (when (and (derived-mode-p 'org-mode) + (ignore-errors (org-back-to-heading t))) + (catch 'exit + (let* ((beg (point)) + (specific (and (stringp which) (upcase which))) + (which (cond ((not specific) which) + ((member specific org-special-properties) 'special) + (t 'standard))) + props) + ;; Get the special properties, like TODO and TAGS. + (when (memq which '(nil all special)) + (when (or (not specific) (string= specific "CLOCKSUM")) + (let ((clocksum (get-text-property (point) :org-clock-minutes))) + (when clocksum + (push (cons "CLOCKSUM" + (org-minutes-to-clocksum-string clocksum)) + props))) + (when specific (throw 'exit props))) + (when (or (not specific) (string= specific "CLOCKSUM_T")) + (let ((clocksumt (get-text-property (point) + :org-clock-minutes-today))) + (when clocksumt + (push (cons "CLOCKSUM_T" + (org-minutes-to-clocksum-string clocksumt)) + props))) + (when specific (throw 'exit props))) + (when (or (not specific) (string= specific "ITEM")) + (let ((case-fold-search nil)) + (when (looking-at org-complex-heading-regexp) + (push (cons "ITEM" + (let ((title (match-string-no-properties 4))) + (if (org-string-nw-p title) + (org-remove-tabs title) + ""))) + props))) + (when specific (throw 'exit props))) + (when (or (not specific) (string= specific "TODO")) + (let ((case-fold-search nil)) + (when (and (looking-at org-todo-line-regexp) (match-end 2)) + (push (cons "TODO" (match-string-no-properties 2)) props))) + (when specific (throw 'exit props))) + (when (or (not specific) (string= specific "PRIORITY")) + (push (cons "PRIORITY" + (if (looking-at org-priority-regexp) + (match-string-no-properties 2) + (char-to-string org-default-priority))) + props) + (when specific (throw 'exit props))) + (when (or (not specific) (string= specific "FILE")) + (push (cons "FILE" (buffer-file-name (buffer-base-buffer))) + 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))) + (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 ":"))) + props))) + (when specific (throw 'exit props))) + (when (or (not specific) (string= specific "BLOCKED")) + (push (cons "BLOCKED" (if (org-entry-blocked-p) "t" "")) props) + (when specific (throw 'exit props))) + (when (or (not specific) + (member specific '("CLOSED" "DEADLINE" "SCHEDULED"))) + (forward-line) + (when (looking-at-p org-planning-line-re) + (end-of-line) + (let ((bol (line-beginning-position)) + ;; Backward compatibility: time keywords used to + ;; be configurable (before 8.3). Make sure we + ;; get the correct keyword. + (key-assoc `(("CLOSED" . ,org-closed-string) + ("DEADLINE" . ,org-deadline-string) + ("SCHEDULED" . ,org-scheduled-string)))) + (dolist (pair (if specific (list (assoc specific key-assoc)) + key-assoc)) + (save-excursion + (when (search-backward (cdr pair) bol t) + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (and (looking-at org-ts-regexp-both) + (push (cons (car pair) + (match-string-no-properties 0)) + props))))))) + (when specific (throw 'exit props))) + (when (or (not specific) + (member specific '("TIMESTAMP" "TIMESTAMP_IA"))) + (let ((find-ts + (lambda (end ts) + ;; Fix next time-stamp before END. TS is the + ;; list of time-stamps found so far. + (let ((ts ts) + (regexp (cond + ((string= specific "TIMESTAMP") + org-ts-regexp) + ((string= specific "TIMESTAMP_IA") + org-ts-regexp-inactive) + ((assoc "TIMESTAMP_IA" ts) + org-ts-regexp) + ((assoc "TIMESTAMP" ts) + org-ts-regexp-inactive) + (t org-ts-regexp-both)))) + (catch 'next + (while (re-search-forward regexp end t) + (backward-char) + (let ((object (org-element-context))) + ;; Accept to match timestamps in node + ;; properties, too. + (when (memq (org-element-type object) + '(node-property timestamp)) + (let ((type + (org-element-property :type object))) + (cond + ((and (memq type '(active active-range)) + (not (equal specific "TIMESTAMP_IA"))) + (unless (assoc "TIMESTAMP" ts) + (push (cons "TIMESTAMP" + (org-element-property + :raw-value object)) + ts) + (when specific (throw 'exit ts)))) + ((and (memq type '(inactive inactive-range)) + (not (string= specific "TIMESTAMP"))) + (unless (assoc "TIMESTAMP_IA" ts) + (push (cons "TIMESTAMP_IA" + (org-element-property + :raw-value object)) + ts) + (when specific (throw 'exit ts)))))) + ;; Both timestamp types are found, + ;; move to next part. + (when (= (length ts) 2) (throw 'next ts))))) + ts))))) + (goto-char beg) + ;; First look for timestamps within headline. + (let ((ts (funcall find-ts (line-end-position) nil))) + (if (= (length ts) 2) (setq props (nconc ts props)) + ;; Then find timestamps in the section, skipping + ;; planning line. + (let ((end (save-excursion (outline-next-heading)))) + (forward-line) + (when (looking-at-p org-planning-line-re) (forward-line)) + (setq props (nconc (funcall find-ts end ts) props)))))))) + ;; Get the standard properties, like :PROP:. + (when (memq which '(nil all standard)) + ;; If we are looking after a specific property, delegate + ;; to `org-entry-get', which is faster. However, make an + ;; exception for "CATEGORY", since it can be also set + ;; through keywords (i.e. #+CATEGORY). + (if (and specific (not (equal specific "CATEGORY"))) + (let ((value (org-entry-get beg specific nil t))) + (throw 'exit (and value (list (cons specific value))))) + (let ((range (org-get-property-block beg))) + (when range + (let ((end (cdr range)) seen-base) + (goto-char (car range)) + ;; Unlike to `org--update-property-plist', we + ;; handle the case where base values is found + ;; after its extension. We also forbid standard + ;; properties to be named as special properties. + (while (re-search-forward org-property-re end t) + (let* ((key (upcase (match-string-no-properties 2))) + (extendp (string-match-p "\\+\\'" key)) + (key-base (if extendp (substring key 0 -1) key)) + (value (match-string-no-properties 3))) + (cond + ((member-ignore-case key-base org-special-properties)) + (extendp + (setq props + (org--update-property-plist key value props))) + ((member key seen-base)) + (t (push key seen-base) + (let ((p (assoc-string key props t))) + (if p (setcdr p (concat value " " (cdr p))) + (push (cons key value) props)))))))))))) + (unless (assoc "CATEGORY" props) + (push (cons "CATEGORY" (org-get-category beg)) props) + (when (string= specific "CATEGORY") (throw 'exit props))) + ;; Return value. + props))))) + +(defun org--property-local-values (property literal-nil) + "Return value for PROPERTY in current entry. +Value is a list whose car is the base value for PROPERTY and cdr +a list of accumulated values. Return nil if neither is found in +the entry. Also return nil when PROPERTY is set to \"nil\", +unless LITERAL-NIL is non-nil." + (let ((range (org-get-property-block))) + (when range + (goto-char (car range)) + (let* ((case-fold-search t) + (end (cdr range)) + (value + ;; Base value. + (save-excursion + (let ((v (and (re-search-forward + (org-re-property property nil t) end t) + (match-string-no-properties 3)))) + (list (if literal-nil v (org-not-nil v))))))) + ;; Find additional values. + (let* ((property+ (org-re-property (concat property "+") nil t))) + (while (re-search-forward property+ end t) + (push (match-string-no-properties 3) value))) + ;; Return final values. + (and (not (equal value '(nil))) (nreverse value)))))) + +(defun org--property-global-value (property literal-nil) + "Return value for PROPERTY in current buffer. +Return value is a string. Return nil if property is not set +globally. Also return nil when PROPERTY is set to \"nil\", +unless LITERAL-NIL is non-nil." + (let ((global + (cdr (or (assoc-string property org-file-properties t) + (assoc-string property org-global-properties t) + (assoc-string property org-global-properties-fixed t))))) + (if literal-nil global (org-not-nil global)))) (defun org-entry-get (pom property &optional inherit literal-nil) "Get value of PROPERTY for entry or content at point-or-marker POM. -If INHERIT is non-nil and the entry does not have the property, -then also check higher levels of the hierarchy. -If INHERIT is the symbol `selective', use inheritance only if the setting -in `org-use-property-inheritance' selects PROPERTY for inheritance. -If the property is present but empty, the return value is the empty string. -If the property is not present at all, nil is returned. -Return the value as a string. - -If LITERAL-NIL is set, return the string value \"nil\" as a string, -do not interpret it as the list atom nil. This is used for inheritance -when a \"nil\" value can supersede a non-nil value higher up the hierarchy." +If INHERIT is non-nil and the entry does not have the property, +then also check higher levels of the hierarchy. If INHERIT is +the symbol `selective', use inheritance only if the setting in +`org-use-property-inheritance' selects PROPERTY for inheritance. + +If the property is present but empty, the return value is the +empty string. If the property is not present at all, nil is +returned. In any other case, return the value as a string. +Search is case-insensitive. + +If LITERAL-NIL is set, return the string value \"nil\" as +a string, do not interpret it as the list atom nil. This is used +for inheritance when a \"nil\" value can supersede a non-nil +value higher up the hierarchy." (org-with-point-at pom - (if (and inherit (if (eq inherit 'selective) - (org-property-inherit-p property) - t)) - (org-entry-get-with-inheritance property literal-nil) - (if (member property org-special-properties) - ;; We need a special property. Use `org-entry-properties' - ;; to retrieve it, but specify the wanted property - (cdr (assoc property (org-entry-properties nil 'special property))) - (org-with-wide-buffer - (let ((range (org-get-property-block))) - (when (and range (not (eq (car range) (cdr range))) - (save-excursion - (goto-char (car range)) - (re-search-forward - (concat (org-re-property property) "\\|" - (org-re-property (concat property "+"))) - (cdr range) t))) - (let* ((props - (list (or (assoc property org-file-properties) - (assoc property org-global-properties) - (assoc property org-global-properties-fixed)))) - (ap (lambda (key) - (when (re-search-forward - (org-re-property key) (cdr range) t) - (setq props - (org-update-property-plist - key - (if (match-end 3) - (org-match-string-no-properties 3) "") - props))))) - val) - (goto-char (car range)) - (funcall ap property) - (goto-char (car range)) - (while (funcall ap (concat property "+"))) - (setq val (cdr (assoc property props))) - (when val (if literal-nil val (org-not-nil val))))))))))) + (cond + ((member-ignore-case property (cons "CATEGORY" org-special-properties)) + ;; We need a special property. Use `org-entry-properties' to + ;; retrieve it, but specify the wanted property. + (cdr (assoc-string property (org-entry-properties nil property)))) + ((and inherit + (or (not (eq inherit 'selective)) (org-property-inherit-p property))) + (org-entry-get-with-inheritance property literal-nil)) + (t + (let* ((local (org--property-local-values property literal-nil)) + (value (and local (mapconcat #'identity (delq nil local) " ")))) + (if literal-nil value (org-not-nil value))))))) (defun org-property-or-variable-value (var &optional inherit) "Check if there is a property fixing the value of VAR. @@ -15430,26 +16012,26 @@ If yes, return this value. If not, return the current value of the variable." (read prop) (symbol-value var)))) -(defun org-entry-delete (pom property &optional delete-empty-drawer) - "Delete the property PROPERTY from entry at point-or-marker POM. -When optional argument DELETE-EMPTY-DRAWER is a string, it defines -an empty drawer to delete." +(defun org-entry-delete (pom property) + "Delete PROPERTY from entry at point-or-marker POM. +Accumulated properties, i.e. PROPERTY+, are also removed. Return +non-nil when a property was removed." (org-with-point-at pom - (if (member property org-special-properties) - nil ; cannot delete these properties. - (let ((range (org-get-property-block))) - (if (and range - (goto-char (car range)) - (re-search-forward - (org-re-property property nil t) - (cdr range) t)) - (progn - (delete-region (match-beginning 0) (1+ (point-at-eol))) - (and delete-empty-drawer - (org-remove-empty-drawer-at - delete-empty-drawer (car range))) - t) - nil))))) + (pcase (org-get-property-block) + (`(,begin . ,origin) + (let* ((end (copy-marker origin)) + (re (org-re-property + (concat (regexp-quote property) "\\+?") t t))) + (goto-char begin) + (while (re-search-forward re end t) + (delete-region (match-beginning 0) (line-beginning-position 2))) + ;; If drawer is empty, remove it altogether. + (when (= begin end) + (delete-region (line-beginning-position 0) + (line-beginning-position 2))) + ;; Return non-nil if some property was removed. + (prog1 (/= end origin) (set-marker end nil)))) + (_ nil)))) ;; Multi-values properties are properties that contain multiple values ;; These values are assumed to be single words, separated by whitespace. @@ -15526,24 +16108,29 @@ If the value found is \"nil\", return nil to show that the property should be considered as undefined (this is the meaning of nil here). However, if LITERAL-NIL is set, return the string value \"nil\" instead." (move-marker org-entry-property-inherited-from nil) - (let (tmp) - (save-excursion - (save-restriction - (widen) - (catch 'ex - (while t - (when (setq tmp (org-entry-get nil property nil literal-nil)) - (or (ignore-errors (org-back-to-heading t)) - (goto-char (point-min))) - (move-marker org-entry-property-inherited-from (point)) - (throw 'ex tmp)) - (or (ignore-errors (org-up-heading-safe)) - (throw 'ex nil)))))) - (setq tmp (or tmp - (cdr (assoc property org-file-properties)) - (cdr (assoc property org-global-properties)) - (cdr (assoc property org-global-properties-fixed)))) - (if literal-nil tmp (org-not-nil tmp)))) + (org-with-wide-buffer + (let (value) + (catch 'exit + (while t + (let ((v (org--property-local-values property literal-nil))) + (when v + (setq value + (concat (mapconcat #'identity (delq nil v) " ") + (and value " ") + value))) + (cond + ((car v) + (org-back-to-heading t) + (move-marker org-entry-property-inherited-from (point)) + (throw 'exit nil)) + ((org-up-heading-safe)) + (t + (let ((global (org--property-global-value property literal-nil))) + (cond ((not global)) + (value (setq value (concat global " " value))) + (t (setq value global)))) + (throw 'exit nil)))))) + (if literal-nil value (org-not-nil value))))) (defvar org-property-changed-functions nil "Hook called when the value of a property has changed. @@ -15552,177 +16139,188 @@ and the new value.") (defun org-entry-put (pom property value) "Set PROPERTY to VALUE for entry at point-or-marker POM. -If the value is nil, it is converted to the empty string. -If it is not a string, an error is raised." + +If the value is nil, it is converted to the empty string. If it +is not a string, an error is raised. Also raise an error on +invalid property names. + +PROPERTY can be any regular property (see +`org-special-properties'). It can also be \"TODO\", +\"PRIORITY\", \"SCHEDULED\" and \"DEADLINE\". + +For the last two properties, VALUE may have any of the special +values \"earlier\" and \"later\". The function then increases or +decreases scheduled or deadline date by one day." (cond ((null value) (setq value "")) - ((not (stringp value)) - (error "Properties values should be strings."))) + ((not (stringp value)) (error "Properties values should be strings")) + ((not (org--valid-property-p property)) + (user-error "Invalid property name: \"%s\"" property))) (org-with-point-at pom - (org-back-to-heading t) - (let ((beg (point)) (end (save-excursion (outline-next-heading) (point))) - range) + (if (or (not (featurep 'org-inlinetask)) (org-inlinetask-in-task-p)) + (org-back-to-heading t) + (org-with-limited-levels (org-back-to-heading t))) + (let ((beg (point))) (cond ((equal property "TODO") - (when (and (string-match "\\S-" value) - (not (member value org-todo-keywords-1))) - (user-error "\"%s\" is not a valid TODO state" value)) - (if (or (not value) - (not (string-match "\\S-" value))) - (setq value 'none)) + (cond ((not (org-string-nw-p value)) (setq value 'none)) + ((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)) ((equal property "PRIORITY") - (org-priority (if (and value (string-match "\\S-" value)) - (string-to-char value) ?\ )) + (org-priority (if (org-string-nw-p value) (string-to-char value) ?\s)) (org-set-tags nil 'align)) - ((equal property "CLOCKSUM") - (if (not (re-search-forward - (concat org-clock-string ".*\\]--\\(\\[[^]]+\\]\\)") nil t)) - (error "Cannot find a clock log") - (goto-char (- (match-end 1) 2)) - (cond - ((eq value 'earlier) (org-timestamp-down)) - ((eq value 'later) (org-timestamp-up))) - (org-clock-sum-current-item))) ((equal property "SCHEDULED") - (if (re-search-forward org-scheduled-time-regexp end t) - (cond - ((eq value 'earlier) (org-timestamp-change -1 'day)) - ((eq value 'later) (org-timestamp-change 1 'day)) - (t (call-interactively 'org-schedule))) - (call-interactively 'org-schedule))) + (forward-line) + (if (and (looking-at-p org-planning-line-re) + (re-search-forward + org-scheduled-time-regexp (line-end-position) t)) + (cond ((string= value "earlier") (org-timestamp-change -1 'day)) + ((string= value "later") (org-timestamp-change 1 'day)) + ((string= value "") (org-schedule '(4))) + (t (org-schedule nil value))) + (if (member value '("earlier" "later" "")) + (call-interactively #'org-schedule) + (org-schedule nil value)))) ((equal property "DEADLINE") - (if (re-search-forward org-deadline-time-regexp end t) - (cond - ((eq value 'earlier) (org-timestamp-change -1 'day)) - ((eq value 'later) (org-timestamp-change 1 'day)) - (t (call-interactively 'org-deadline))) - (call-interactively 'org-deadline))) + (forward-line) + (if (and (looking-at-p org-planning-line-re) + (re-search-forward + org-deadline-time-regexp (line-end-position) t)) + (cond ((string= value "earlier") (org-timestamp-change -1 'day)) + ((string= value "later") (org-timestamp-change 1 'day)) + ((string= value "") (org-deadline '(4))) + (t (org-deadline nil value))) + (if (member value '("earlier" "later" "")) + (call-interactively #'org-deadline) + (org-deadline nil value)))) ((member property org-special-properties) - (error "The %s property can not yet be set with `org-entry-put'" - property)) - (t ; a non-special property - (let ((buffer-invisibility-spec (org-inhibit-invisibility))) ; Emacs 21 - (setq range (org-get-property-block beg end 'force)) + (error "The %s property cannot be set with `org-entry-put'" property)) + (t + (let* ((range (org-get-property-block beg 'force)) + (end (cdr range)) + (case-fold-search t)) (goto-char (car range)) - (if (re-search-forward - (org-re-property property nil t) (cdr range) t) - (progn - (delete-region (match-beginning 0) (match-end 0)) - (goto-char (match-beginning 0))) - (goto-char (cdr range)) + (if (re-search-forward (org-re-property property nil t) end t) + (progn (delete-region (match-beginning 0) (match-end 0)) + (goto-char (match-beginning 0))) + (goto-char end) (insert "\n") - (backward-char 1) - (org-indent-line)) + (backward-char)) (insert ":" property ":") - (and value (insert " " value)) + (when value (insert " " value)) (org-indent-line))))) (run-hook-with-args 'org-property-changed-functions property value))) -(defun org-buffer-property-keys (&optional include-specials include-defaults include-columns) +(defun org-buffer-property-keys + (&optional specials defaults columns ignore-malformed) "Get all property keys in the current buffer. -With INCLUDE-SPECIALS, also list the special properties that reflect things -like tags and TODO state. -With INCLUDE-DEFAULTS, also include properties that has special meaning -internally: ARCHIVE, CATEGORY, SUMMARY, DESCRIPTION, LOCATION, and LOGGING -and others. -With INCLUDE-COLUMNS, also include property names given in COLUMN -formats in the current buffer." - (let (rtn range cfmt s p) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward org-property-start-re nil t) - (setq range (org-get-property-block)) - (goto-char (car range)) - (while (re-search-forward org-property-re - (cdr range) t) - (add-to-list 'rtn (org-match-string-no-properties 2))) - (outline-next-heading)))) - (when include-specials - (setq rtn (append org-special-properties rtn))) +When SPECIALS is non-nil, also list the special properties that +reflect things like tags and TODO state. - (when include-defaults - (mapc (lambda (x) (add-to-list 'rtn x)) org-default-properties) - (add-to-list 'rtn org-effort-property)) +When DEFAULTS is non-nil, also include properties that has +special meaning internally: ARCHIVE, CATEGORY, SUMMARY, +DESCRIPTION, LOCATION, and LOGGING and others. - (when include-columns - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward - "^\\(#\\+COLUMNS:\\|[ \t]*:COLUMNS:\\)[ \t]*\\(.*\\)" - nil t) - (setq cfmt (match-string 2) s 0) - (while (string-match (org-re "%[0-9]*\\([-[:alnum:]_]+\\)") - cfmt s) - (setq s (match-end 0) - p (match-string 1 cfmt)) - (unless (or (equal p "ITEM") - (member p org-special-properties)) - (add-to-list 'rtn (match-string 1 cfmt)))))))) - - (sort rtn (lambda (a b) (string< (upcase a) (upcase b)))))) +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." + (let ((case-fold-search t) + (props (append + (and specials org-special-properties) + (and defaults (cons org-effort-property org-default-properties)) + nil))) + (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)) + (goto-char (car range)) + (let ((begin (car range)) + (end (cdr range))) + ;; Make sure that found property block is not located + ;; before current point, as it would generate an infloop. + ;; It can happen, for example, in the following + ;; situation: + ;; + ;; * Headline + ;; :PROPERTIES: + ;; ... + ;; :END: + ;; *************** Inlinetask + ;; #+BEGIN_EXAMPLE + ;; :PROPERTIES: + ;; #+END_EXAMPLE + ;; + (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)))) + ;; Only add true property name, not extension symbol. + (push (if (not (string-match-p "\\+\\'" p)) p + (substring p 0 -1)) + props)) + (forward-line)))) + (outline-next-heading))) + (when columns + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*\\(?:#\\+\\|:\\)COLUMNS:" nil t) + (let ((element (org-element-at-point))) + (when (memq (org-element-type element) '(keyword node-property)) + (let ((value (org-element-property :value element)) + (start 0)) + (while (string-match "%[0-9]*\\(\\S-+\\)" value start) + (setq start (match-end 0)) + (let ((p (match-string-no-properties 1 value))) + (unless (member-ignore-case p org-special-properties) + (push p props)))))))))) + (sort (delete-dups props) (lambda (a b) (string< (upcase a) (upcase b)))))) (defun org-property-values (key) - "Return a list of all values of property KEY in the current buffer." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((re (org-re-property key)) - values) - (while (re-search-forward re nil t) - (add-to-list 'values (org-trim (match-string 3)))) - (delete "" values))))) + "List all non-nil values of property KEY in current buffer." + (org-with-wide-buffer + (goto-char (point-min)) + (let ((case-fold-search t) + (re (org-re-property key)) + values) + (while (re-search-forward re nil t) + (push (org-entry-get (point) key) values)) + (delete-dups values)))) (defun org-insert-property-drawer () "Insert a property drawer into the current entry." - (org-back-to-heading t) - (looking-at org-outline-regexp) - (let ((indent (if org-adapt-indentation - (- (match-end 0) (match-beginning 0)) - 0)) - (beg (point)) - (re (concat "^[ \t]*" org-keyword-time-regexp)) - end hiddenp) - (outline-next-heading) - (setq end (point)) - (goto-char beg) - (while (re-search-forward re end t)) - (setq hiddenp (outline-invisible-p)) - (end-of-line 1) - (and (equal (char-after) ?\n) (forward-char 1)) - (while (looking-at "^[ \t]*\\(:CLOCK:\\|:LOGBOOK:\\|CLOCK:\\|:END:\\)") - (if (member (match-string 1) '("CLOCK:" ":END:")) - ;; just skip this line - (beginning-of-line 2) - ;; Drawer start, find the end - (re-search-forward "^\\*+ \\|^[ \t]*:END:" nil t) - (beginning-of-line 1))) - (org-skip-over-state-notes) - (skip-chars-backward " \t\n\r") - (if (and (eq (char-before) ?*) (not (eq (char-after) ?\n))) - (forward-char 1)) - (goto-char (point-at-eol)) - (let ((inhibit-read-only t)) (insert "\n:PROPERTIES:\n:END:")) - (beginning-of-line 0) - (org-indent-to-column indent) - (beginning-of-line 2) - (org-indent-to-column indent) - (beginning-of-line 0) - (if hiddenp - (save-excursion - (org-back-to-heading t) - (hide-entry)) - (org-flag-drawer t)))) + (org-with-wide-buffer + (if (or (not (featurep 'org-inlinetask)) (org-inlinetask-in-task-p)) + (org-back-to-heading t) + (org-with-limited-levels (org-back-to-heading t))) + (forward-line) + (when (looking-at-p org-planning-line-re) (forward-line)) + (unless (looking-at-p org-property-drawer-re) + ;; Make sure we start editing a line from current entry, not from + ;; next one. It prevents extending text properties or overlays + ;; belonging to the latter. + (when (bolp) (backward-char)) + (let ((begin (1+ (point))) + (inhibit-read-only t)) + (insert "\n:PROPERTIES:\n:END:") + (when (eobp) (insert "\n")) + (org-indent-region begin (point)))))) (defun org-insert-drawer (&optional arg drawer) "Insert a drawer at point. +When optional argument ARG is non-nil, insert a property drawer. + Optional argument DRAWER, when non-nil, is a string representing drawer's name. Otherwise, the user is prompted for a name. @@ -15731,23 +16329,14 @@ instead. Point is left between drawer's boundaries." (interactive "P") - (let* ((logbook (if (stringp org-log-into-drawer) org-log-into-drawer - "LOGBOOK")) - ;; SYSTEM-DRAWERS is a list of drawer names that are used - ;; internally by Org. They are meant to be inserted - ;; automatically. - (system-drawers `("CLOCK" ,logbook "PROPERTIES")) - ;; Remove system drawers from list. Note: For some reason, - ;; `org-completing-read' ignores the predicate while - ;; `completing-read' handles it fine. - (drawer (if arg "PROPERTIES" - (or drawer - (completing-read - "Drawer: " org-drawers - (lambda (d) (not (member d system-drawers)))))))) + (let* ((drawer (if arg "PROPERTIES" + (or drawer (read-from-minibuffer "Drawer: "))))) (cond ;; With C-u, fall back on `org-insert-property-drawer' (arg (org-insert-property-drawer)) + ;; Check validity of suggested drawer's name. + ((not (string-match-p org-drawer-regexp (format ":%s:" drawer))) + (user-error "Invalid drawer name")) ;; With an active region, insert a drawer at point. ((not (org-region-active-p)) (progn @@ -15813,38 +16402,25 @@ This is computed according to `org-property-set-functions-alist'." (funcall set-function prompt allowed nil (not (get-text-property 0 'org-unrestricted (caar allowed)))) - (let (org-completion-use-ido org-completion-use-iswitchb) - (funcall set-function prompt - (mapcar 'list (org-property-values property)) - nil nil "" nil cur))))) + (funcall set-function prompt + (mapcar 'list (org-property-values property)) + nil nil "" nil cur)))) (org-trim val))) (defvar org-last-set-property nil) (defvar org-last-set-property-value nil) (defun org-read-property-name () "Read a property name." - (let* ((completion-ignore-case t) - (keys (org-buffer-property-keys nil t t)) - (default-prop (or (save-excursion - (save-match-data - (beginning-of-line) - (and (looking-at "^\\s-*:\\([^:\n]+\\):") - (null (string= (match-string 1) "END")) - (match-string 1)))) - org-last-set-property)) - (property (org-icompleting-read - (concat "Property" - (if default-prop (concat " [" default-prop "]") "") - ": ") - (mapcar 'list keys) - nil nil nil nil - default-prop))) - (if (member property keys) - property - (or (cdr (assoc (downcase property) - (mapcar (lambda (x) (cons (downcase x) x)) - keys))) - property)))) + (let ((completion-ignore-case t) + (default-prop (or (and (org-at-property-p) + (match-string-no-properties 2)) + org-last-set-property))) + (org-completing-read + (concat "Property" + (if default-prop (concat " [" default-prop "]") "") + ": ") + (mapcar #'list (org-buffer-property-keys nil t t)) + nil nil nil nil default-prop))) (defun org-set-property-and-value (use-last) "Allow to set [PROPERTY]: [value] direction from prompt. @@ -15865,26 +16441,52 @@ When use-default, don't even ask, just use the last (defun org-set-property (property value) "In the current entry, set PROPERTY to VALUE. + When called interactively, this will prompt for a property name, offering completion on existing and default properties. And then it will prompt for a value, offering completion either on allowed values (via an inherited xxx_ALL property) or on existing values in other instances of this property -in the current file." +in the current file. + +Throw an error when trying to set a property with an invalid name." (interactive (list nil nil)) - (let* ((property (or property (org-read-property-name))) - (value (or value (org-read-property-value property))) - (fn (cdr (assoc property org-properties-postprocess-alist)))) - (setq org-last-set-property property) - (setq org-last-set-property-value (concat property ": " value)) - ;; Possibly postprocess the inserted value: - (when fn (setq value (funcall fn value))) - (unless (equal (org-entry-get nil property) value) - (org-entry-put nil property value)))) - -(defun org-delete-property (property &optional delete-empty-drawer) - "In the current entry, delete PROPERTY. -When optional argument DELETE-EMPTY-DRAWER is a string, it defines -an empty drawer to delete." + (let ((property (or property (org-read-property-name)))) + ;; `org-entry-put' also makes the following check, but this one + ;; avoids polluting `org-last-set-property' and + ;; `org-last-set-property-value' needlessly. + (unless (org--valid-property-p property) + (user-error "Invalid property name: \"%s\"" property)) + (let ((value (or value (org-read-property-value property))) + (fn (cdr (assoc-string property org-properties-postprocess-alist t)))) + (setq org-last-set-property property) + (setq org-last-set-property-value (concat property ": " value)) + ;; Possibly postprocess the inserted value: + (when fn (setq value (funcall fn value))) + (unless (equal (org-entry-get nil property) value) + (org-entry-put nil property value))))) + +(defun org-find-property (property &optional value) + "Find first entry in buffer that sets PROPERTY. + +When optional argument VALUE is non-nil, only consider an entry +if it contains PROPERTY set to this value. If PROPERTY should be +explicitly set to nil, use string \"nil\" for VALUE. + +Return position where the entry begins, or nil if there is no +such entry. If narrowing is in effect, only search the visible +part of the buffer." + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t) + (re (org-re-property property nil (not value) value))) + (catch 'exit + (while (re-search-forward re nil t) + (when (if value (org-at-property-p) + (org-entry-get (point) property nil t)) + (throw 'exit (progn (org-back-to-heading t) (point))))))))) + +(defun org-delete-property (property) + "In the current entry, delete PROPERTY." (interactive (let* ((completion-ignore-case t) (cat (org-entry-get (point) "CATEGORY")) @@ -15892,33 +16494,30 @@ an empty drawer to delete." (props (if cat props0 (delete `("CATEGORY" . ,(org-get-category)) props0))) (prop (if (< 1 (length props)) - (org-icompleting-read "Property: " props nil t) + (completing-read "Property: " props nil t) (caar props)))) (list prop))) (if (not property) (message "No property to delete in this entry") - (org-entry-delete nil property delete-empty-drawer) + (org-entry-delete nil property) (message "Property \"%s\" deleted" property))) (defun org-delete-property-globally (property) - "Remove PROPERTY globally, from all entries." + "Remove PROPERTY globally, from all entries. +This function ignores narrowing, if any." (interactive (let* ((completion-ignore-case t) - (prop (org-icompleting-read + (prop (completing-read "Globally remove property: " - (mapcar 'list (org-buffer-property-keys))))) + (mapcar #'list (org-buffer-property-keys))))) (list prop))) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((cnt 0)) - (while (re-search-forward - (org-re-property property) - nil t) - (setq cnt (1+ cnt)) - (delete-region (match-beginning 0) (1+ (point-at-eol)))) - (message "Property \"%s\" removed from %d entries" property cnt))))) + (org-with-wide-buffer + (goto-char (point-min)) + (let ((count 0) + (re (org-re-property (concat (regexp-quote property) "\\+?") t t))) + (while (re-search-forward re nil t) + (when (org-entry-delete (point) property) (cl-incf count))) + (message "Property \"%s\" removed from %d entries" property count)))) (defvar org-columns-current-fmt-compiled) ; defined in org-colview.el @@ -15929,9 +16528,9 @@ then applies it to the property in the column format's scope." (interactive) (unless (org-at-property-p) (user-error "Not at a property")) - (let ((prop (org-match-string-no-properties 2))) + (let ((prop (match-string-no-properties 2))) (org-columns-get-format-and-top-level) - (unless (nth 3 (assoc prop org-columns-current-fmt-compiled)) + (unless (nth 3 (assoc-string prop org-columns-current-fmt-compiled t)) (user-error "No operator defined for property %s" prop)) (org-columns-compute prop))) @@ -15958,6 +16557,7 @@ completion." (while (>= n org-highest-priority) (push (char-to-string n) vals) (setq n (1- n))))) + ((equal property "CATEGORY")) ((member property org-special-properties)) ((setq vals (run-hook-with-args-until-success 'org-property-allowed-value-functions property))) @@ -15976,7 +16576,7 @@ completion." (org-add-props (car vals) '(org-unrestricted t))) (if table (mapcar 'list vals) vals))) -(defun org-property-previous-allowed-value (&optional previous) +(defun org-property-previous-allowed-value (&optional _previous) "Switch to the next allowed value for this property." (interactive) (org-property-next-allowed-value t)) @@ -15996,21 +16596,22 @@ completion." nval) (unless allowed (user-error "Allowed values for this property have not been defined")) - (if previous (setq allowed (reverse allowed))) - (if (member value allowed) - (setq nval (car (cdr (member value allowed))))) + (when previous (setq allowed (reverse allowed))) + (when (member value allowed) + (setq nval (car (cdr (member value allowed))))) (setq nval (or nval (car allowed))) - (if (equal nval value) - (user-error "Only one allowed value for this property")) + (when (equal nval value) + (user-error "Only one allowed value for this property")) (org-at-property-p) (replace-match (concat " :" key ": " nval) t t) (org-indent-line) (beginning-of-line 1) (skip-chars-forward " \t") (when (equal prop org-effort-property) - (save-excursion - (org-back-to-heading t) - (put-text-property (point-at-bol) (point-at-eol) 'org-effort nval)) + (org-refresh-property + '((effort . identity) + (effort-minutes . org-duration-string-to-minutes)) + nval) (when (string= org-clock-current-task heading) (setq org-clock-effort nval) (org-clock-update-mode-line))) @@ -16035,31 +16636,28 @@ only headings." (level 1) (lmin 1) (lmax 1) - limit re end found pos heading cnt flevel) + end found flevel) (unless buffer (error "File not found :%s" file)) (with-current-buffer buffer - (save-excursion - (save-restriction - (widen) - (setq limit (point-max)) - (goto-char (point-min)) - (dolist (heading path) - (setq re (format org-complex-heading-regexp-format - (regexp-quote heading))) - (setq cnt 0 pos (point)) - (while (re-search-forward re end t) - (setq level (- (match-end 1) (match-beginning 1))) - (if (and (>= level lmin) (<= level lmax)) - (setq found (match-beginning 0) flevel level cnt (1+ cnt)))) - (when (= cnt 0) (error "Heading not found on level %d: %s" - lmax heading)) - (when (> cnt 1) (error "Heading not unique on level %d: %s" - lmax heading)) - (goto-char found) - (setq lmin (1+ flevel) lmax (+ lmin (if org-odd-levels-only 1 0))) - (setq end (save-excursion (org-end-of-subtree t t)))) - (when (org-at-heading-p) - (point-marker))))))) + (org-with-wide-buffer + (goto-char (point-min)) + (dolist (heading path) + (let ((re (format org-complex-heading-regexp-format + (regexp-quote heading))) + (cnt 0)) + (while (re-search-forward re end t) + (setq level (- (match-end 1) (match-beginning 1))) + (when (and (>= level lmin) (<= level lmax)) + (setq found (match-beginning 0) flevel level cnt (1+ cnt)))) + (when (= cnt 0) + (error "Heading not found on level %d: %s" lmax heading)) + (when (> cnt 1) + (error "Heading not unique on level %d: %s" lmax heading)) + (goto-char found) + (setq lmin (1+ flevel) lmax (+ lmin (if org-odd-levels-only 1 0))) + (setq end (save-excursion (org-end-of-subtree t t))))) + (when (org-at-heading-p) + (point-marker)))))) (defun org-find-exact-headline-in-buffer (heading &optional buffer pos-only) "Find node HEADING in BUFFER. @@ -16069,24 +16667,22 @@ If POS-ONLY is set, return just the position instead of a marker. The heading text must match exact, but it may have a TODO keyword, a priority cookie and tags in the standard locations." (with-current-buffer (or buffer (current-buffer)) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let (case-fold-search) - (if (re-search-forward - (format org-complex-heading-regexp-format - (regexp-quote heading)) nil t) - (if pos-only - (match-beginning 0) - (move-marker (make-marker) (match-beginning 0))))))))) + (org-with-wide-buffer + (goto-char (point-min)) + (let (case-fold-search) + (when (re-search-forward + (format org-complex-heading-regexp-format + (regexp-quote heading)) nil t) + (if pos-only + (match-beginning 0) + (move-marker (make-marker) (match-beginning 0)))))))) (defun org-find-exact-heading-in-directory (heading &optional dir) "Find Org node headline HEADING in all .org files in directory DIR. When the target headline is found, return a marker to this location." (let ((files (directory-files (or dir default-directory) - nil "\\`[^.#].*\\.org\\'")) - file visiting m buffer) + t "\\`[^.#].*\\.org\\'")) + visiting m buffer) (catch 'found (dolist (file files) (message "trying %s" file) @@ -16105,19 +16701,10 @@ Return the position where this entry starts, or nil if there is no such entry." (interactive "sID: ") (let ((id (cond ((stringp ident) ident) - ((symbol-name ident) (symbol-name ident)) + ((symbolp ident) (symbol-name ident)) ((numberp ident) (number-to-string ident)) - (t (error "IDENT %s must be a string, symbol or number" ident)))) - (case-fold-search nil)) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (when (re-search-forward - (concat "^[ \t]*:ID:[ \t]+" (regexp-quote id) "[ \t]*$") - nil t) - (org-back-to-heading t) - (point)))))) + (t (error "IDENT %s must be a string, symbol or number" ident))))) + (org-with-wide-buffer (org-find-property "ID" id)))) ;;;; Timestamps @@ -16128,17 +16715,16 @@ Return the position where this entry starts, or nil if there is no such entry." (defun org-time-stamp (arg &optional inactive) "Prompt for a date/time and insert a time stamp. + If the user specifies a time like HH:MM or if this command is called with at least one prefix argument, the time stamp contains -the date and the time. Otherwise, only the date is be included. +the date and the time. Otherwise, only the date is included. -All parts of a date not specified by the user is filled in from -the current date/time. So if you just press return without -typing anything, the time stamp will represent the current -date/time. +All parts of a date not specified by the user are filled in from +the timestamp at point, if any, or the current date/time +otherwise. -If there is already a timestamp at the cursor, it will be -modified. +If there is already a timestamp at the cursor, it is replaced. With two universal prefix arguments, insert an active timestamp with the current time without prompting the user. @@ -16146,57 +16732,56 @@ with the current time without prompting the user. When called from lisp, the timestamp is inactive if INACTIVE is non-nil." (interactive "P") - (let* ((ts nil) - (default-time - ;; Default time is either today, or, when entering a range, - ;; the range start. - (if (or (and (org-at-timestamp-p t) (setq ts (match-string 0))) - (save-excursion - (re-search-backward - (concat org-ts-regexp "--?-?\\=") ; 1-3 minuses - (- (point) 20) t))) - (apply 'encode-time (org-parse-time-string (match-string 1))) - (current-time))) - (default-input (and ts (org-get-compact-tod ts))) - (repeater (save-excursion - (save-match-data - (beginning-of-line) - (when (re-search-forward - "\\([.+-]+[0-9]+[hdwmy] ?\\)+" ;;\\(?:[/ ][-+]?[0-9]+[hdwmy]\\)?\\) ?" - (save-excursion (progn (end-of-line) (point))) t) - (match-string 0))))) - org-time-was-given org-end-time-was-given time) + (let* ((ts (cond + ((org-at-date-range-p t) + (match-string (if (< (point) (- (match-beginning 2) 2)) 1 2))) + ((org-at-timestamp-p t) (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 (if (not ts) (current-time) + (apply #'encode-time (org-parse-time-string 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 + (and (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 (org-at-timestamp-p t) - (memq last-command '(org-time-stamp org-time-stamp-inactive)) - (memq this-command '(org-time-stamp org-time-stamp-inactive))) + ((and ts + (memq last-command '(org-time-stamp org-time-stamp-inactive)) + (memq this-command '(org-time-stamp org-time-stamp-inactive))) (insert "--") - (setq time (let ((this-command this-command)) - (org-read-date arg 'totime nil nil - default-time default-input inactive))) (org-insert-time-stamp time (or org-time-was-given arg) inactive)) - ((org-at-timestamp-p t) - (setq time (let ((this-command this-command)) - (org-read-date arg 'totime nil nil default-time default-input inactive))) - (when (org-at-timestamp-p t) ; just to get the match data - ; (setq inactive (eq (char-after (match-beginning 0)) ?\[)) - (replace-match "") + (ts + ;; Make sure we're on a timestamp. When in the middle of a date + ;; range, move arbitrarily to range end. + (unless (org-at-timestamp-p t) + (skip-chars-forward "-") + (org-at-timestamp-p t)) + (replace-match "") + (setq org-last-changed-timestamp + (org-insert-time-stamp + time (or org-time-was-given arg) + inactive nil nil (list org-end-time-was-given))) + (when repeater + (backward-char) + (insert " " repeater) (setq org-last-changed-timestamp - (org-insert-time-stamp - time (or org-time-was-given arg) - inactive nil nil (list org-end-time-was-given))) - (when repeater (goto-char (1- (point))) (insert " " repeater) - (setq org-last-changed-timestamp - (concat (substring org-last-inserted-timestamp 0 -1) - " " repeater ">")))) + (concat (substring org-last-inserted-timestamp 0 -1) + " " repeater ">"))) (message "Timestamp updated")) - ((equal arg '(16)) - (org-insert-time-stamp (current-time) t inactive)) - (t - (setq time (let ((this-command this-command)) - (org-read-date arg 'totime nil nil default-time default-input inactive))) - (org-insert-time-stamp time (or org-time-was-given arg) inactive - nil nil (list org-end-time-was-given)))))) + ((equal arg '(16)) (org-insert-time-stamp time t inactive)) + (t (org-insert-time-stamp + time (or org-time-was-given arg) inactive nil nil + (list org-end-time-was-given)))))) ;; FIXME: can we use this for something else, like computing time differences? (defun org-get-compact-tod (s) @@ -16211,7 +16796,7 @@ non-nil." (if (not t2) t1 (setq dh (- h2 h1) dm (- m2 m1)) - (if (< dm 0) (setq dm (+ dm 60) dh (1- dh))) + (when (< dm 0) (setq dm (+ dm 60) dh (1- dh))) (concat t1 "+" (number-to-string dh) (and (/= 0 dm) (format ":%02d" dm))))))) @@ -16226,7 +16811,7 @@ So these are more for recording a certain time/date." (defvar org-date-ovl (make-overlay 1 1)) (overlay-put org-date-ovl 'face 'org-date-selected) -(org-detach-overlay org-date-ovl) +(delete-overlay org-date-ovl) (defvar org-ans1) ; dynamically scoped parameter (defvar org-ans2) ; dynamically scoped parameter @@ -16243,13 +16828,14 @@ So these are more for recording a certain time/date." (defvar org-read-date-inactive) (defvar org-read-date-minibuffer-local-map - (let* ((org-replace-disputed-keys nil) - (map (make-sparse-keymap))) + (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 "^[^:]+: ") + (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-.") @@ -16316,7 +16902,8 @@ So these are more for recording a certain time/date." (defvar org-defdecode) (defvar org-with-time) -(defun org-read-date (&optional org-with-time to-time from-string prompt +(defvar calendar-setup) ; Dynamically scoped. +(defun org-read-date (&optional with-time to-time from-string prompt default-time default-input inactive) "Read a date, possibly a time, and make things smooth for the user. The prompt will suggest to enter an ISO date, but you can also enter anything @@ -16360,8 +16947,8 @@ If you don't like the calendar, turn it off with With optional argument TO-TIME, the date will immediately be converted to an internal time. -With an optional argument ORG-WITH-TIME, the prompt will suggest to -also insert a time. Note that when ORG-WITH-TIME is not set, you can +With an optional argument WITH-TIME, the prompt will suggest to +also insert a time. Note that when WITH-TIME is not set, you can still enter a time, and this function will inform the calling routine about this change. The calling routine may then choose to change the format used to insert the time stamp into the buffer to include the time. @@ -16370,75 +16957,90 @@ the user. PROMPT can overwrite the default prompt. DEFAULT-TIME is the time/date that is used for everything that is not specified by the user." (require 'parse-time) - (let* ((org-time-stamp-rounding-minutes - (if (equal org-with-time '(16)) '(0 0) org-time-stamp-rounding-minutes)) + (let* ((org-with-time with-time) + (org-time-stamp-rounding-minutes + (if (equal org-with-time '(16)) + '(0 0) + org-time-stamp-rounding-minutes)) (org-dcst org-display-custom-times) (ct (org-current-time)) (org-def (or org-overriding-default-time default-time ct)) (org-defdecode (decode-time org-def)) - (dummy (progn - (when (< (nth 2 org-defdecode) org-extend-today-until) - (setcar (nthcdr 2 org-defdecode) -1) - (setcar (nthcdr 1 org-defdecode) 59) - (setq org-def (apply 'encode-time org-defdecode) - org-defdecode (decode-time org-def))))) - (mouse-autoselect-window nil) ; Don't let the mouse jump - (calendar-frame-setup nil) - (calendar-setup nil) + (cur-frame (selected-frame)) + (mouse-autoselect-window nil) ; Don't let the mouse jump + (calendar-setup + (and (eq calendar-setup 'calendar-only) 'calendar-only)) (calendar-move-hook nil) (calendar-view-diary-initially-flag nil) (calendar-view-holidays-initially-flag nil) - (timestr (format-time-string - (if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") org-def)) - (prompt (concat (if prompt (concat prompt " ") "") - (format "Date+time [%s]: " timestr))) - ans (org-ans0 "") org-ans1 org-ans2 final) - - (cond - (from-string (setq ans from-string)) - (org-read-date-popup-calendar - (save-excursion - (save-window-excursion - (calendar) - (org-eval-in-calendar '(setq cursor-type nil) t) - (unwind-protect - (progn - (calendar-forward-day (- (time-to-days org-def) - (calendar-absolute-from-gregorian - (calendar-current-date)))) - (org-eval-in-calendar nil t) - (let* ((old-map (current-local-map)) - (map (copy-keymap calendar-mode-map)) - (minibuffer-local-map - (copy-keymap org-read-date-minibuffer-local-map))) - (org-defkey map (kbd "RET") 'org-calendar-select) - (org-defkey map [mouse-1] 'org-calendar-select-mouse) - (org-defkey map [mouse-2] 'org-calendar-select-mouse) - (unwind-protect - (progn - (use-local-map map) - (setq org-read-date-inactive inactive) - (add-hook 'post-command-hook 'org-read-date-display) - (setq org-ans0 (read-string prompt default-input - 'org-read-date-history nil)) - ;; org-ans0: from prompt - ;; org-ans1: from mouse click - ;; org-ans2: from calendar motion - (setq ans (concat org-ans0 " " (or org-ans1 org-ans2)))) - (remove-hook 'post-command-hook 'org-read-date-display) - (use-local-map old-map) - (when org-read-date-overlay - (delete-overlay org-read-date-overlay) - (setq org-read-date-overlay nil))))) - (bury-buffer "*Calendar*"))))) - - (t ; Naked prompt only - (unwind-protect - (setq ans (read-string prompt default-input - 'org-read-date-history timestr)) - (when org-read-date-overlay - (delete-overlay org-read-date-overlay) - (setq org-read-date-overlay nil))))) + ans (org-ans0 "") org-ans1 org-ans2 final cal-frame) + ;; Rationalize `org-def' and `org-defdecode', if required. + (when (< (nth 2 org-defdecode) org-extend-today-until) + (setf (nth 2 org-defdecode) -1) + (setf (nth 1 org-defdecode) 59) + (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") + org-def)) + (prompt (concat (if prompt (concat prompt " ") "") + (format "Date+time [%s]: " timestr)))) + (cond + (from-string (setq ans from-string)) + (org-read-date-popup-calendar + (save-excursion + (save-window-excursion + (calendar) + (when (eq calendar-setup 'calendar-only) + (setq cal-frame + (window-frame (get-buffer-window "*Calendar*" 'visible))) + (select-frame cal-frame)) + (org-eval-in-calendar '(setq cursor-type nil) t) + (unwind-protect + (progn + (calendar-forward-day (- (time-to-days org-def) + (calendar-absolute-from-gregorian + (calendar-current-date)))) + (org-eval-in-calendar nil t) + (let* ((old-map (current-local-map)) + (map (copy-keymap calendar-mode-map)) + (minibuffer-local-map + (copy-keymap org-read-date-minibuffer-local-map))) + (org-defkey map (kbd "RET") 'org-calendar-select) + (org-defkey map [mouse-1] 'org-calendar-select-mouse) + (org-defkey map [mouse-2] 'org-calendar-select-mouse) + (unwind-protect + (progn + (use-local-map map) + (setq org-read-date-inactive inactive) + (add-hook 'post-command-hook 'org-read-date-display) + (setq org-ans0 + (read-string prompt + default-input + 'org-read-date-history + nil)) + ;; org-ans0: from prompt + ;; org-ans1: from mouse click + ;; org-ans2: from calendar motion + (setq ans + (concat org-ans0 " " (or org-ans1 org-ans2)))) + (remove-hook 'post-command-hook 'org-read-date-display) + (use-local-map old-map) + (when org-read-date-overlay + (delete-overlay org-read-date-overlay) + (setq org-read-date-overlay nil))))) + (bury-buffer "*Calendar*") + (when cal-frame + (delete-frame cal-frame) + (select-frame-set-input-focus cur-frame)))))) + + (t ; Naked prompt only + (unwind-protect + (setq ans (read-string prompt default-input + 'org-read-date-history timestr)) + (when org-read-date-overlay + (delete-overlay org-read-date-overlay) + (setq org-read-date-overlay nil)))))) (setq final (org-read-date-analyze ans org-def org-defdecode)) @@ -16499,13 +17101,18 @@ user." (make-overlay (1- (point-at-eol)) (point-at-eol))) (org-overlay-display org-read-date-overlay txt 'secondary-selection))))) -(defun org-read-date-analyze (ans org-def org-defdecode) +(defun org-read-date-analyze (ans def defdecode) "Analyze the combined answer of the date prompt." ;; FIXME: cleanup and comment - (let ((nowdecode (decode-time)) + ;; Pass `current-time' result to `decode-time' (instead of calling + ;; without arguments) so that only `current-time' has to be + ;; overriden in tests. + (let ((org-def def) + (org-defdecode defdecode) + (nowdecode (decode-time (current-time))) delta deltan deltaw deltadef year month day hour minute second wday pm h2 m2 tl wday1 - iso-year iso-weekday iso-week iso-year iso-date futurep kill-year) + iso-year iso-weekday iso-week iso-date futurep kill-year) (setq org-read-date-analyze-futurep nil org-read-date-analyze-forced-year nil) (when (string-match "\\`[ \t]*\\.[ \t]*\\'" ans) @@ -16521,11 +17128,11 @@ user." ;; info and postpone interpreting it until the rest of the parsing ;; is done. (when (string-match "\\<\\(?:\\([0-9]+\\)-\\)?[wW]\\([0-9]\\{1,2\\}\\)\\(?:-\\([0-6]\\)\\)?\\([ \t]\\|$\\)" ans) - (setq iso-year (if (match-end 1) - (org-small-year-to-year - (string-to-number (match-string 1 ans)))) - iso-weekday (if (match-end 3) - (string-to-number (match-string 3 ans))) + (setq iso-year (when (match-end 1) + (org-small-year-to-year + (string-to-number (match-string 1 ans)))) + iso-weekday (when (match-end 3) + (string-to-number (match-string 3 ans))) iso-week (string-to-number (match-string 2 ans))) (setq ans (replace-match "" t t ans))) @@ -16538,7 +17145,7 @@ user." (string-to-number (format-time-string "%Y")))) month (string-to-number (match-string 3 ans)) day (string-to-number (match-string 4 ans))) - (if (< year 100) (setq year (+ 2000 year))) + (setq year (org-small-year-to-year year)) (setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day) t nil ans))) @@ -16562,26 +17169,26 @@ user." (string-to-number (format-time-string "%Y")))) month (string-to-number (match-string 1 ans)) day (string-to-number (match-string 2 ans))) - (if (< year 100) (setq year (+ 2000 year))) + (setq year (org-small-year-to-year year)) (setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day) t nil ans))) ;; Help matching am/pm times, because `parse-time-string' does not do that. ;; If there is a time with am/pm, and *no* time without it, we convert ;; so that matching will be successful. - (loop for i from 1 to 2 do ; twice, for end time as well - (when (and (not (string-match "\\(\\`\\|[^+]\\)[012]?[0-9]:[0-9][0-9]\\([ \t\n]\\|$\\)" ans)) - (string-match "\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\(am\\|AM\\|pm\\|PM\\)\\>" ans)) - (setq hour (string-to-number (match-string 1 ans)) - minute (if (match-end 3) - (string-to-number (match-string 3 ans)) - 0) - pm (equal ?p - (string-to-char (downcase (match-string 4 ans))))) - (if (and (= hour 12) (not pm)) - (setq hour 0) - (if (and pm (< hour 12)) (setq hour (+ 12 hour)))) - (setq ans (replace-match (format "%02d:%02d" hour minute) - t t ans)))) + (cl-loop for i from 1 to 2 do ; twice, for end time as well + (when (and (not (string-match "\\(\\`\\|[^+]\\)[012]?[0-9]:[0-9][0-9]\\([ \t\n]\\|$\\)" ans)) + (string-match "\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\(am\\|AM\\|pm\\|PM\\)\\>" ans)) + (setq hour (string-to-number (match-string 1 ans)) + minute (if (match-end 3) + (string-to-number (match-string 3 ans)) + 0) + pm (equal ?p + (string-to-char (downcase (match-string 4 ans))))) + (if (and (= hour 12) (not pm)) + (setq hour 0) + (when (and pm (< hour 12)) (setq hour (+ 12 hour)))) + (setq ans (replace-match (format "%02d:%02d" hour minute) + t t ans)))) ;; Check if a time range is given as a duration (when (string-match "\\([012]?[0-9]\\):\\([0-6][0-9]\\)\\+\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?" ans) @@ -16590,7 +17197,7 @@ user." minute (string-to-number (match-string 2 ans)) m2 (+ minute (if (match-end 5) (string-to-number (match-string 5 ans))0))) - (if (>= m2 60) (setq h2 (1+ h2) m2 (- m2 60))) + (when (>= m2 60) (setq h2 (1+ h2) m2 (- m2 60))) (setq ans (replace-match (format "%02d:%02d-%02d:%02d" hour minute h2 m2) t t ans))) @@ -16605,16 +17212,35 @@ user." (setq tl (parse-time-string ans) day (or (nth 3 tl) (nth 3 org-defdecode)) - month (or (nth 4 tl) - (if (and org-read-date-prefer-future - (nth 3 tl) (< (nth 3 tl) (nth 3 nowdecode))) - (prog1 (1+ (nth 4 nowdecode)) (setq futurep t)) - (nth 4 org-defdecode))) - year (or (and (not kill-year) (nth 5 tl)) - (if (and org-read-date-prefer-future - (nth 4 tl) (< (nth 4 tl) (nth 4 nowdecode))) - (prog1 (1+ (nth 5 nowdecode)) (setq futurep t)) - (nth 5 org-defdecode))) + month + (cond ((nth 4 tl)) + ((not org-read-date-prefer-future) (nth 4 org-defdecode)) + ;; Day was specified. Make sure DAY+MONTH + ;; combination happens in the future. + ((nth 3 tl) + (setq futurep t) + (if (< day (nth 3 nowdecode)) (1+ (nth 4 nowdecode)) + (nth 4 nowdecode))) + (t (nth 4 org-defdecode))) + year + (cond ((and (not kill-year) (nth 5 tl))) + ((not org-read-date-prefer-future) (nth 5 org-defdecode)) + ;; Month was guessed in the future and is at least + ;; equal to NOWDECODE's. Fix year accordingly. + (futurep + (if (or (> month (nth 4 nowdecode)) + (>= day (nth 3 nowdecode))) + (nth 5 nowdecode) + (1+ (nth 5 nowdecode)))) + ;; Month was specified. Make sure MONTH+YEAR + ;; combination happens in the future. + ((nth 4 tl) + (setq futurep t) + (cond ((> month (nth 4 nowdecode)) (nth 5 nowdecode)) + ((< month (nth 4 nowdecode)) (1+ (nth 5 nowdecode))) + ((< day (nth 3 nowdecode)) (1+ (nth 5 nowdecode))) + (t (nth 5 nowdecode)))) + (t (nth 5 org-defdecode))) hour (or (nth 2 tl) (nth 2 org-defdecode)) minute (or (nth 1 tl) (nth 1 org-defdecode)) second (or (nth 0 tl) 0) @@ -16643,7 +17269,7 @@ user." day (or iso-weekday wday 1) wday nil ; to make sure that the trigger below does not match iso-date (calendar-gregorian-from-absolute - (calendar-absolute-from-iso + (calendar-iso-to-absolute (list iso-week day year)))) ; FIXME: Should we also push ISO weeks into the future? ; (when (and org-read-date-prefer-future @@ -16652,7 +17278,7 @@ user." ; (time-to-days (current-time)))) ; (setq year (1+ year) ; iso-date (calendar-gregorian-from-absolute - ; (calendar-absolute-from-iso + ; (calendar-iso-to-absolute ; (list iso-week day year))))) (setq month (car iso-date) year (nth 2 iso-date) @@ -16660,7 +17286,10 @@ user." (deltan (setq futurep nil) (unless deltadef - (let ((now (decode-time))) + ;; Pass `current-time' result to `decode-time' (instead of + ;; calling without arguments) so that only `current-time' has + ;; to be overriden in tests. + (let ((now (decode-time (current-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)))) @@ -16672,17 +17301,17 @@ user." (setq wday1 (nth 6 (decode-time (encode-time 0 0 0 day month year)))) (unless (equal wday wday1) (setq day (+ day (% (- wday wday1 -7) 7)))))) - (if (and (boundp 'org-time-was-given) - (nth 2 tl)) - (setq org-time-was-given t)) - (if (< year 100) (setq year (+ 2000 year))) + (when (and (boundp 'org-time-was-given) + (nth 2 tl)) + (setq org-time-was-given t)) + (when (< year 100) (setq year (+ 2000 year))) ;; Check of the date is representable (if org-read-date-force-compatible-dates (progn - (if (< year 1970) - (setq year 1970 org-read-date-analyze-forced-year t)) - (if (> year 2037) - (setq year 2037 org-read-date-analyze-forced-year t))) + (when (< year 1970) + (setq year 1970 org-read-date-analyze-forced-year t)) + (when (> year 2037) + (setq year 2037 org-read-date-analyze-forced-year t))) (condition-case nil (ignore (encode-time second minute hour day month year)) (error @@ -16722,12 +17351,11 @@ DEF-FLAG is t when a double ++ or -- indicates shift relative to (if wday1 (progn (setq delta (mod (+ 7 (- wday1 wday)) 7)) - (if (= delta 0) (setq delta 7)) - (if (= dir ?-) - (progn - (setq delta (- delta 7)) - (if (= delta 0) (setq delta -7)))) - (if (> n 1) (setq delta (+ delta (* (1- n) (if (= dir ?-) -7 7))))) + (when (= delta 0) (setq delta 7)) + (when (= dir ?-) + (setq delta (- delta 7)) + (when (= delta 0) (setq delta -7))) + (when (> n 1) (setq delta (+ delta (* (1- n) (if (= dir ?-) -7 7))))) (list delta "d" rel)) (list (* n (if (= dir ?-) -1 1)) what rel))))) @@ -16736,23 +17364,14 @@ DEF-FLAG is t when a double ++ or -- indicates shift relative to The internal representation needed by the calendar is (month day year). This is a wrapper to handle the brain-dead convention in calendar that user function argument order change dependent on argument order." - (if (boundp 'calendar-date-style) - (cond - ((eq calendar-date-style 'american) - (list arg1 arg2 arg3)) - ((eq calendar-date-style 'european) - (list arg2 arg1 arg3)) - ((eq calendar-date-style 'iso) - (list arg2 arg3 arg1))) - (org-no-warnings ;; european-calendar-style is obsolete as of version 23.1 - (if (org-bound-and-true-p european-calendar-style) - (list arg2 arg1 arg3) - (list arg1 arg2 arg3))))) + (pcase calendar-date-style + (`american (list arg1 arg2 arg3)) + (`european (list arg2 arg1 arg3)) + (`iso (list arg2 arg3 arg1)))) (defun org-eval-in-calendar (form &optional keepdate) "Eval FORM in the calendar window and return to current window. -When KEEPDATE is non-nil, update `org-ans2' from the cursor date, -otherwise stick to the current value of `org-ans2'." +Unless KEEPDATE is non-nil, update `org-ans2' to the cursor date." (let ((sf (selected-frame)) (sw (selected-window))) (select-window (get-buffer-window "*Calendar*" t)) @@ -16763,7 +17382,7 @@ otherwise stick to the current value of `org-ans2'." (setq org-ans2 (format-time-string "%Y-%m-%d" time)))) (move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer)) (select-window sw) - (org-select-frame-set-input-focus sf))) + (select-frame-set-input-focus sf))) (defun org-calendar-select () "Return to `org-read-date' with the date currently selected. @@ -16773,10 +17392,11 @@ This is used by `org-read-date' in a temporary keymap for the calendar buffer." (let* ((date (calendar-cursor-to-date)) (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) (setq org-ans1 (format-time-string "%Y-%m-%d" time))) - (if (active-minibuffer-window) (exit-minibuffer)))) + (when (active-minibuffer-window) (exit-minibuffer)))) (defun org-insert-time-stamp (time &optional with-hm inactive pre post extra) "Insert a date stamp for the date given by the internal TIME. +See `format-time-string' for the format of TIME. WITH-HM means use the stamp format that includes the time of the day. INACTIVE means use square brackets instead of angular ones, so that the stamp will not contribute to the agenda. @@ -16785,7 +17405,7 @@ stamp. The command returns the inserted time stamp." (let ((fmt (funcall (if with-hm 'cdr 'car) org-time-stamp-formats)) stamp) - (if inactive (setq fmt (concat "[" (substring fmt 1 -1) "]"))) + (when inactive (setq fmt (concat "[" (substring fmt 1 -1) "]"))) (insert-before-markers (or pre "")) (when (listp extra) (setq extra (car extra)) @@ -16808,14 +17428,12 @@ The command returns the inserted time stamp." (unless org-display-custom-times (let ((p (point-min)) (bmp (buffer-modified-p))) (while (setq p (next-single-property-change p 'display)) - (if (and (get-text-property p 'display) - (eq (get-text-property p 'face) 'org-date)) - (remove-text-properties - p (setq p (next-single-property-change p 'display)) - '(display t)))) + (when (and (get-text-property p 'display) + (eq (get-text-property p 'face) 'org-date)) + (remove-text-properties + p (setq p (next-single-property-change p 'display)) + '(display t)))) (set-buffer-modified-p bmp))) - (if (featurep 'xemacs) - (remove-text-properties (point-min) (point-max) '(end-glyph t))) (org-restart-font-lock) (setq org-table-may-need-update t) (if org-display-custom-times @@ -16828,8 +17446,8 @@ The command returns the inserted time stamp." t1 w1 with-hm tf time str w2 (off 0)) (save-match-data (setq t1 (org-parse-time-string ts t)) - (if (string-match "\\(-[0-9]+:[0-9]+\\)?\\( [.+]?\\+[0-9]+[hdwmy]\\(/[0-9]+[hdwmy]\\)?\\)?\\'" ts) - (setq off (- (match-end 0) (match-beginning 0))))) + (when (string-match "\\(-[0-9]+:[0-9]+\\)?\\( [.+]?\\+[0-9]+[hdwmy]\\(/[0-9]+[hdwmy]\\)?\\)?\\'" ts) + (setq off (- (match-end 0) (match-beginning 0))))) (setq end (- end off)) (setq w1 (- end beg) with-hm (and (nth 1 t1) (nth 2 t1)) @@ -16840,41 +17458,10 @@ The command returns the inserted time stamp." (substring tf 1 -1) (apply 'encode-time time)) nil 'mouse-face 'highlight) w2 (length str)) - (if (not (= w2 w1)) - (add-text-properties (1+ beg) (+ 2 beg) - (list 'org-dwidth t 'org-dwidth-n (- w1 w2)))) - (if (featurep 'xemacs) - (progn - (put-text-property beg end 'invisible t) - (put-text-property beg end 'end-glyph (make-glyph str))) - (put-text-property beg end 'display str)))) - -(defun org-translate-time (string) - "Translate all timestamps in STRING to custom format. -But do this only if the variable `org-display-custom-times' is set." - (when org-display-custom-times - (save-match-data - (let* ((start 0) - (re org-ts-regexp-both) - t1 with-hm inactive tf time str beg end) - (while (setq start (string-match re string start)) - (setq beg (match-beginning 0) - end (match-end 0) - t1 (save-match-data - (org-parse-time-string (substring string beg end) t)) - with-hm (and (nth 1 t1) (nth 2 t1)) - inactive (equal (substring string beg (1+ beg)) "[") - tf (funcall (if with-hm 'cdr 'car) - org-time-stamp-custom-formats) - time (org-fix-decoded-time t1) - str (format-time-string - (concat - (if inactive "[" "<") (substring tf 1 -1) - (if inactive "]" ">")) - (apply 'encode-time time)) - string (replace-match str t t string) - start (+ start (length str))))))) - string) + (unless (= w2 w1) + (add-text-properties (1+ beg) (+ 2 beg) + (list 'org-dwidth t 'org-dwidth-n (- w1 w2)))) + (put-text-property beg end 'display str))) (defun org-fix-decoded-time (time) "Set 0 instead of nil for the first 6 elements of time. @@ -16882,19 +17469,17 @@ Don't touch the rest." (let ((n 0)) (mapcar (lambda (x) (if (< (setq n (1+ n)) 7) (or x 0) x)) time))) -(define-obsolete-function-alias 'org-days-to-time 'org-time-stamp-to-now "24.4") - (defun org-time-stamp-to-now (timestamp-string &optional seconds) "Difference between TIMESTAMP-STRING and now in days. If SECONDS is non-nil, return the difference in seconds." - (let ((fdiff (if seconds 'float-time 'time-to-days))) + (let ((fdiff (if seconds #'float-time #'time-to-days))) (- (funcall fdiff (org-time-string-to-time timestamp-string)) (funcall fdiff (current-time))))) -(defun org-deadline-close (timestamp-string &optional ndays) +(defun org-deadline-close-p (timestamp-string &optional ndays) "Is the time in TIMESTAMP-STRING close to the current date?" (setq ndays (or ndays (org-get-wdays timestamp-string))) - (and (< (org-time-stamp-to-now timestamp-string) ndays) + (and (<= (org-time-stamp-to-now timestamp-string) ndays) (not (org-entry-is-done-p)))) (defun org-get-wdays (ts &optional delay zero-delay) @@ -16930,14 +17515,15 @@ This is used by `org-read-date' in a temporary keymap for the calendar buffer." (let* ((date (calendar-cursor-to-date)) (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) (setq org-ans1 (format-time-string "%Y-%m-%d" time))) - (if (active-minibuffer-window) (exit-minibuffer)))) + (when (active-minibuffer-window) (exit-minibuffer)))) (defun org-check-deadlines (ndays) "Check if there are any deadlines due or past due. A deadline is considered due if it happens within `org-deadline-warning-days' days from today's date. If the deadline appears in an entry marked DONE, -it is not shown. The prefix arg NDAYS can be used to test that many -days. If the prefix is a raw \\[universal-argument] prefix, all deadlines are shown." +it is not shown. A numeric prefix argument NDAYS can be used to test that +many days. If the prefix is a raw `\\[universal-argument]', all deadlines \ +are shown." (interactive "P") (let* ((org-warn-days (cond @@ -16947,8 +17533,7 @@ days. If the prefix is a raw \\[universal-argument] prefix, all deadlines are s (case-fold-search nil) (regexp (concat "\\<" org-deadline-string " *<\\([^>]+\\)>")) (callback - (lambda () (org-deadline-close (match-string 1) org-warn-days)))) - + (lambda () (org-deadline-close-p (match-string 1) org-warn-days)))) (message "%d deadlines past-due or due within %d days" (org-occur regexp nil callback) org-warn-days))) @@ -16966,39 +17551,61 @@ Allowed values for TYPE are: When TYPE is nil, fall back on returning a regexp that matches both scheduled and deadline timestamps." - (cond ((eq type 'all) "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\(?: +[^]+0-9>\r\n -]+\\)?\\(?: +[0-9]\\{1,2\\}:[0-9]\\{2\\}\\)?\\)") - ((eq type 'active) org-ts-regexp) - ((eq type 'inactive) "\\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)\\]") - ((eq type 'scheduled) (concat "\\<" org-scheduled-string " *<\\([^>]+\\)>")) - ((eq type 'deadline) (concat "\\<" org-deadline-string " *<\\([^>]+\\)>")) - ((eq type 'closed) (concat org-closed-string " \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)\\]")) - ((eq type 'scheduled-or-deadline) - (concat "\\<\\(?:" org-deadline-string "\\|" org-scheduled-string "\\) *<\\([^>]+\\)>")))) - -(defun org-check-before-date (date) - "Check if there are deadlines or scheduled entries before DATE." + (cl-case type + (all org-ts-regexp-both) + (active org-ts-regexp) + (inactive org-ts-regexp-inactive) + (scheduled org-scheduled-time-regexp) + (deadline org-deadline-time-regexp) + (closed org-closed-time-regexp) + (otherwise + (concat "\\<" + (regexp-opt (list org-deadline-string org-scheduled-string)) + " *<\\([^>]+\\)>")))) + +(defun org-check-before-date (d) + "Check if there are deadlines or scheduled entries before date D." (interactive (list (org-read-date))) - (let ((case-fold-search nil) - (regexp (org-re-timestamp org-ts-type)) - (callback - (lambda () (time-less-p - (org-time-string-to-time (match-string 1)) - (org-time-string-to-time date))))) + (let* ((case-fold-search nil) + (regexp (org-re-timestamp org-ts-type)) + (ts-type org-ts-type) + (callback + (lambda () + (let ((match (match-string 1))) + (and (if (memq ts-type '(active inactive all)) + (eq (org-element-type (save-excursion + (backward-char) + (org-element-context))) + 'timestamp) + (org-at-planning-p)) + (time-less-p + (org-time-string-to-time match) + (org-time-string-to-time d))))))) (message "%d entries before %s" - (org-occur regexp nil callback) date))) + (org-occur regexp nil callback) + d))) -(defun org-check-after-date (date) - "Check if there are deadlines or scheduled entries after DATE." +(defun org-check-after-date (d) + "Check if there are deadlines or scheduled entries after date D." (interactive (list (org-read-date))) - (let ((case-fold-search nil) - (regexp (org-re-timestamp org-ts-type)) - (callback - (lambda () (not - (time-less-p - (org-time-string-to-time (match-string 1)) - (org-time-string-to-time date)))))) + (let* ((case-fold-search nil) + (regexp (org-re-timestamp org-ts-type)) + (ts-type org-ts-type) + (callback + (lambda () + (let ((match (match-string 1))) + (and (if (memq ts-type '(active inactive all)) + (eq (org-element-type (save-excursion + (backward-char) + (org-element-context))) + 'timestamp) + (org-at-planning-p)) + (not (time-less-p + (org-time-string-to-time match) + (org-time-string-to-time d)))))))) (message "%d entries after %s" - (org-occur regexp nil callback) date))) + (org-occur regexp nil callback) + d))) (defun org-check-dates-range (start-date end-date) "Check for deadlines/scheduled entries between START-DATE and END-DATE." @@ -17007,15 +17614,22 @@ both scheduled and deadline timestamps." (let ((case-fold-search nil) (regexp (org-re-timestamp org-ts-type)) (callback - (lambda () - (let ((match (match-string 1))) - (and - (not (time-less-p - (org-time-string-to-time match) - (org-time-string-to-time start-date))) - (time-less-p - (org-time-string-to-time match) - (org-time-string-to-time end-date))))))) + (let ((type org-ts-type)) + (lambda () + (let ((match (match-string 1))) + (and + (if (memq type '(active inactive all)) + (eq (org-element-type (save-excursion + (backward-char) + (org-element-context))) + 'timestamp) + (org-at-planning-p)) + (not (time-less-p + (org-time-string-to-time match) + (org-time-string-to-time start-date))) + (time-less-p + (org-time-string-to-time match) + (org-time-string-to-time end-date)))))))) (message "%d entries between %s and %s" (org-occur regexp nil callback) start-date end-date))) @@ -17034,8 +17648,8 @@ days in order to avoid rounding problems." (unless (org-at-date-range-p t) (goto-char (point-at-bol)) (re-search-forward org-tr-regexp-both (point-at-eol) t)) - (if (not (org-at-date-range-p t)) - (user-error "Not at a time-stamp range, and none found in current line"))) + (unless (org-at-date-range-p t) + (user-error "Not at a time-stamp range, and none found in current line"))) (let* ((ts1 (match-string 1)) (ts2 (match-string 2)) (havetime (or (> (length ts1) 15) (> (length ts2) 15))) @@ -17073,27 +17687,31 @@ days in order to avoid rounding problems." (setq align t) (and (looking-at " *|") (goto-char (match-end 0)))) (goto-char match-end)) - (if (looking-at - "\\( *-? *[0-9]+y\\)?\\( *[0-9]+d\\)? *[0-9][0-9]:[0-9][0-9]") - (replace-match "")) - (if negative (insert " -")) + (when (looking-at + "\\( *-? *[0-9]+y\\)?\\( *[0-9]+d\\)? *[0-9][0-9]:[0-9][0-9]") + (replace-match "")) + (when negative (insert " -")) (if (> y 0) (insert " " (format (if havetime fy fy1) y d h m)) (if (> d 0) (insert " " (format (if havetime fd fd1) d h m)) (insert " " (format fh h m)))) - (if align (org-table-align)) + (when align (org-table-align)) (message "Time difference inserted"))))) (defun org-make-tdiff-string (y d h m) (let ((fmt "") (l nil)) - (if (> y 0) (setq fmt (concat fmt "%d year" (if (> y 1) "s" "") " ") - l (push y l))) - (if (> d 0) (setq fmt (concat fmt "%d day" (if (> d 1) "s" "") " ") - l (push d l))) - (if (> h 0) (setq fmt (concat fmt "%d hour" (if (> h 1) "s" "") " ") - l (push h l))) - (if (> m 0) (setq fmt (concat fmt "%d minute" (if (> m 1) "s" "") " ") - l (push m l))) + (when (> y 0) + (setq fmt (concat fmt "%d year" (if (> y 1) "s" "") " ")) + (push y l)) + (when (> d 0) + (setq fmt (concat fmt "%d day" (if (> d 1) "s" "") " ")) + (push d l)) + (when (> h 0) + (setq fmt (concat fmt "%d hour" (if (> h 1) "s" "") " ")) + (push h l)) + (when (> m 0) + (setq fmt (concat fmt "%d minute" (if (> m 1) "s" "") " ")) + (push m l)) (apply 'format fmt (nreverse l)))) (defun org-time-string-to-time (s &optional buffer pos) @@ -17110,28 +17728,40 @@ days in order to avoid rounding problems." "Convert a timestamp string to a number of seconds." (float-time (org-time-string-to-time s))) -(defun org-time-string-to-absolute (s &optional daynr prefer show-all buffer pos) - "Convert a time stamp to an absolute day number. -If there is a specifier for a cyclic time stamp, get the closest -date to DAYNR. -PREFER and SHOW-ALL are passed through to `org-closest-date'. -The variable `date' is bound by the calendar when this is called." +(org-define-error 'org-diary-sexp-no-match "Unable to match diary sexp") + +(defun org-time-string-to-absolute (s &optional daynr prefer buffer pos) + "Convert time stamp S to an absolute day number. + +If DAYNR in non-nil, and there is a specifier for a cyclic time +stamp, get the closest date to DAYNR. If PREFER is +`past' (respectively `future') return a date past (respectively +after) or equal to DAYNR. + +POS is the location of time stamp S, as a buffer position in +BUFFER. + +Diary sexp timestamps are matched against DAYNR, when non-nil. +If matching fails or DAYNR is nil, `org-diary-sexp-no-match' is +signalled." (cond - ((and daynr (string-match "\\`%%\\((.*)\\)" s)) - (if (org-diary-sexp-entry (match-string 1 s) "" date) + ((string-match "\\`%%\\((.*)\\)" s) + ;; Sexp timestamp: try to match DAYNR, if available, since we're + ;; only able to match individual dates. If it fails, raise an + ;; error. + (if (and daynr + (org-diary-sexp-entry + (match-string 1 s) "" (calendar-gregorian-from-absolute daynr))) daynr - (+ daynr 1000))) - ((and daynr (string-match "\\+[0-9]+[hdwmy]" s)) - (org-closest-date s (if (and (boundp 'daynr) (integerp daynr)) daynr - (time-to-days (current-time))) (match-string 0 s) - prefer show-all)) + (signal 'org-diary-sexp-no-match (list s)))) + (daynr (org-closest-date s daynr prefer)) (t (time-to-days (condition-case errdata - (apply 'encode-time (org-parse-time-string s)) + (apply #'encode-time (org-parse-time-string s)) (error (error "Bad timestamp `%s'%s\nError was: %s" - s (if (not (and buffer pos)) - "" - (format-message " at %d in buffer `%s'" pos buffer)) + s + (if (not (and buffer pos)) "" + (format-message " at %d in buffer `%s'" pos buffer)) (cdr errdata)))))))) (defun org-days-to-iso-week (days) @@ -17141,43 +17771,46 @@ The variable `date' is bound by the calendar when this is called." (defun org-small-year-to-year (year) "Convert 2-digit years into 4-digit years. -38-99 are mapped into 1938-1999. 1-37 are mapped into 2001-2037. -The year 2000 cannot be abbreviated. Any year larger than 99 -is returned unchanged." - (if (< year 38) - (setq year (+ 2000 year)) - (if (< year 100) - (setq year (+ 1900 year)))) - year) +YEAR is expanded into one of the 30 next years, if possible, or +into a past one. Any year larger than 99 is returned unchanged." + (if (>= year 100) year + (let* ((current (string-to-number (format-time-string "%Y" (current-time)))) + (century (/ current 100)) + (offset (- year (% current 100)))) + (cond ((> offset 30) (+ (* (1- century) 100) year)) + ((> offset -70) (+ (* century 100) year)) + (t (+ (* (1+ century) 100) year)))))) (defun org-time-from-absolute (d) "Return the time corresponding to date D. D may be an absolute day number, or a calendar-type list (month day year)." - (if (numberp d) (setq d (calendar-gregorian-from-absolute d))) + (when (numberp d) (setq d (calendar-gregorian-from-absolute d))) (encode-time 0 0 0 (nth 1 d) (car d) (nth 2 d))) +(defvar org-agenda-current-date) (defun org-calendar-holiday () - "List of holidays, for Diary display in Org-mode." + "List of holidays, for Diary display in Org mode." (require 'holidays) - (let ((hl (funcall - (if (fboundp 'calendar-check-holidays) - 'calendar-check-holidays 'check-calendar-holidays) date))) - (if hl (mapconcat 'identity hl "; ")))) + (let ((hl (calendar-check-holidays org-agenda-current-date))) + (and hl (mapconcat #'identity hl "; ")))) -(defun org-diary-sexp-entry (sexp entry date) - "Process a SEXP diary ENTRY for DATE." +(defun org-diary-sexp-entry (sexp entry d) + "Process a SEXP diary ENTRY for date D." (require 'diary-lib) - (let ((result (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car (read-from-string sexp)))) - (condition-case nil - (eval (car (read-from-string sexp))) - (error - (beep) - (message "Bad sexp at line %d in %s: %s" - (org-current-line) - (buffer-file-name) sexp) - (sleep-for 2)))))) + ;; `org-anniversary' and alike expect ENTRY and DATE to be bound + ;; dynamically. + (let* ((sexp `(let ((entry ,entry) + (date ',d)) + ,(car (read-from-string sexp)))) + (result (if calendar-debug-sexp (eval sexp) + (condition-case nil + (eval sexp) + (error + (beep) + (message "Bad sexp at line %d in %s: %s" + (org-current-line) + (buffer-file-name) sexp) + (sleep-for 2)))))) (cond ((stringp result) (split-string result "; ")) ((and (consp result) (not (consp (cdr result))) @@ -17189,9 +17822,7 @@ D may be an absolute day number, or a calendar-type list (month day year)." (defun org-diary-to-ical-string (frombuf) "Get iCalendar entries from diary entries in buffer FROMBUF. This uses the icalendar.el library." - (let* ((tmpdir (if (featurep 'xemacs) - (temp-directory) - temporary-file-directory)) + (let* ((tmpdir temporary-file-directory) (tmpfile (make-temp-name (expand-file-name "orgics" tmpdir))) buf rtn b e) @@ -17200,125 +17831,146 @@ This uses the icalendar.el library." (setq buf (find-buffer-visiting tmpfile)) (set-buffer buf) (goto-char (point-min)) - (if (re-search-forward "^BEGIN:VEVENT" nil t) - (setq b (match-beginning 0))) + (when (re-search-forward "^BEGIN:VEVENT" nil t) + (setq b (match-beginning 0))) (goto-char (point-max)) - (if (re-search-backward "^END:VEVENT" nil t) - (setq e (match-end 0))) + (when (re-search-backward "^END:VEVENT" nil t) + (setq e (match-end 0))) (setq rtn (if (and b e) (concat (buffer-substring b e) "\n") ""))) (kill-buffer buf) (delete-file tmpfile) rtn)) -(defun org-closest-date (start current change prefer show-all) - "Find the date closest to CURRENT that is consistent with START and CHANGE. -When PREFER is `past', return a date that is either CURRENT or past. -When PREFER is `future', return a date that is either CURRENT or future. -When SHOW-ALL is nil, only return the current occurrence of a time stamp." - ;; Make the proper lists from the dates - (catch 'exit - (let ((a1 '(("h" . hour) - ("d" . day) - ("w" . week) - ("m" . month) - ("y" . year))) - (shour (nth 2 (org-parse-time-string start))) - dn dw sday cday n1 n2 n0 - d m y y1 y2 date1 date2 nmonths nm ny m2) - - (setq start (org-date-to-gregorian start) - current (org-date-to-gregorian - (if show-all - current - (time-to-days (current-time)))) - sday (calendar-absolute-from-gregorian start) - cday (calendar-absolute-from-gregorian current)) - - (if (<= cday sday) (throw 'exit sday)) - - (if (string-match "\\(\\+[0-9]+\\)\\([hdwmy]\\)" change) - (setq dn (string-to-number (match-string 1 change)) - dw (cdr (assoc (match-string 2 change) a1))) - (user-error "Invalid change specifier: %s" change)) - (if (eq dw 'week) (setq dw 'day dn (* 7 dn))) - (cond - ((eq dw 'hour) - (let ((missing-hours - (mod (+ (- (* 24 (- cday sday)) shour) org-extend-today-until) - dn))) - (setq n1 (if (zerop missing-hours) cday - (- cday (1+ (floor (/ missing-hours 24))))) - n2 (+ cday (floor (/ (- dn missing-hours) 24)))))) - ((eq dw 'day) - (setq n1 (+ sday (* dn (floor (/ (- cday sday) dn)))) - n2 (+ n1 dn))) - ((eq dw 'year) - (setq d (nth 1 start) m (car start) y1 (nth 2 start) y2 (nth 2 current)) - (setq y1 (+ (* (floor (/ (- y2 y1) dn)) dn) y1)) - (setq date1 (list m d y1) - n1 (calendar-absolute-from-gregorian date1) - date2 (list m d (+ y1 (* (if (< n1 cday) 1 -1) dn))) - n2 (calendar-absolute-from-gregorian date2))) - ((eq dw 'month) - ;; approx number of month between the two dates - (setq nmonths (floor (/ (- cday sday) 30.436875))) - ;; How often does dn fit in there? - (setq d (nth 1 start) m (car start) y (nth 2 start) - nm (* dn (max 0 (1- (floor (/ nmonths dn))))) - m (+ m nm) - ny (floor (/ m 12)) - y (+ y ny) - m (- m (* ny 12))) - (while (> m 12) (setq m (- m 12) y (1+ y))) - (setq n1 (calendar-absolute-from-gregorian (list m d y))) - (setq m2 (+ m dn) y2 y) - (if (> m2 12) (setq y2 (1+ y2) m2 (- m2 12))) - (setq n2 (calendar-absolute-from-gregorian (list m2 d y2))) - (while (<= n2 cday) - (setq n1 n2 m m2 y y2) - (setq m2 (+ m dn) y2 y) - (if (> m2 12) (setq y2 (1+ y2) m2 (- m2 12))) - (setq n2 (calendar-absolute-from-gregorian (list m2 d y2)))))) - ;; Make sure n1 is the earlier date - (setq n0 n1 n1 (min n1 n2) n2 (max n0 n2)) - (if show-all - (cond - ((eq prefer 'past) (if (= cday n2) n2 n1)) - ((eq prefer 'future) (if (= cday n1) n1 n2)) - (t (if (> (abs (- cday n1)) (abs (- cday n2))) n2 n1))) - (cond - ((eq prefer 'past) (if (= cday n2) n2 n1)) - ((eq prefer 'future) (if (= cday n1) n1 n2)) - (t (if (= cday n1) n1 n2))))))) - -(defun org-date-to-gregorian (date) - "Turn any specification of DATE into a Gregorian date for the calendar." - (cond ((integerp date) (calendar-gregorian-from-absolute date)) - ((and (listp date) (= (length date) 3)) date) - ((stringp date) - (setq date (org-parse-time-string date)) - (list (nth 4 date) (nth 3 date) (nth 5 date))) - ((listp date) - (list (nth 4 date) (nth 3 date) (nth 5 date))))) - -(defun org-parse-time-string (s &optional nodefault) - "Parse the standard Org-mode time string. +(defun org-closest-date (start current prefer) + "Return closest date to CURRENT starting from START. + +CURRENT and START are both time stamps. + +When PREFER is `past', return a date that is either CURRENT or +past. When PREFER is `future', return a date that is either +CURRENT or future. + +Only time stamps with a repeater are modified. Any other time +stamp stay unchanged. In any case, return value is an absolute +day number." + (if (not (string-match "\\+\\([0-9]+\\)\\([hdwmy]\\)" start)) + ;; No repeater. Do not shift time stamp. + (time-to-days (apply #'encode-time (org-parse-time-string start))) + (let ((value (string-to-number (match-string 1 start))) + (type (match-string 2 start))) + (if (= 0 value) + ;; Repeater with a 0-value is considered as void. + (time-to-days (apply #'encode-time (org-parse-time-string start))) + (let* ((base (org-date-to-gregorian start)) + (target (org-date-to-gregorian current)) + (sday (calendar-absolute-from-gregorian base)) + (cday (calendar-absolute-from-gregorian target)) + n1 n2) + ;; If START is already past CURRENT, just return START. + (if (<= cday sday) sday + ;; Compute closest date before (N1) and closest date past + ;; (N2) CURRENT. + (pcase type + ("h" + (let ((missing-hours + (mod (+ (- (* 24 (- cday sday)) + (nth 2 (org-parse-time-string start))) + org-extend-today-until) + value))) + (setf n1 (if (= missing-hours 0) cday + (- cday (1+ (/ missing-hours 24))))) + (setf n2 (+ cday (/ (- value missing-hours) 24))))) + ((or "d" "w") + (let ((value (if (equal type "w") (* 7 value) value))) + (setf n1 (+ sday (* value (/ (- cday sday) value)))) + (setf n2 (+ n1 value)))) + ("m" + (let* ((add-months + (lambda (d n) + ;; Add N months to gregorian date D, i.e., + ;; a list (MONTH DAY YEAR). Return a valid + ;; gregorian date. + (let ((m (+ (nth 0 d) n))) + (list (mod m 12) + (nth 1 d) + (+ (/ m 12) (nth 2 d)))))) + (months ; Complete months to TARGET. + (* (/ (+ (* 12 (- (nth 2 target) (nth 2 base))) + (- (nth 0 target) (nth 0 base)) + ;; If START's day is greater than + ;; TARGET's, remove incomplete month. + (if (> (nth 1 target) (nth 1 base)) 0 -1)) + value) + value)) + (before (funcall add-months base months))) + (setf n1 (calendar-absolute-from-gregorian before)) + (setf n2 + (calendar-absolute-from-gregorian + (funcall add-months before value))))) + (_ + (let* ((d (nth 1 base)) + (m (nth 0 base)) + (y (nth 2 base)) + (years ; Complete years to TARGET. + (* (/ (- (nth 2 target) + y + ;; If START's month and day are + ;; greater than TARGET's, remove + ;; incomplete year. + (if (or (> (nth 0 target) m) + (and (= (nth 0 target) m) + (> (nth 1 target) d))) + 0 + 1)) + value) + value)) + (before (list m d (+ y years)))) + (setf n1 (calendar-absolute-from-gregorian before)) + (setf n2 (calendar-absolute-from-gregorian + (list m d (+ (nth 2 before) value))))))) + ;; Handle PREFER parameter, if any. + (cond + ((eq prefer 'past) (if (= cday n2) n2 n1)) + ((eq prefer 'future) (if (= cday n1) n1 n2)) + (t (if (> (abs (- cday n1)) (abs (- cday n2))) n2 n1))))))))) + +(defun org-date-to-gregorian (d) + "Turn any specification of date D into a Gregorian date for the calendar." + (cond ((integerp d) (calendar-gregorian-from-absolute d)) + ((and (listp d) (= (length d) 3)) d) + ((stringp d) + (let ((d (org-parse-time-string d))) + (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 zone) + "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." + +If time is not given, defaults to 0:00. However, with optional +NODEFAULT, hour and minute fields will be nil if not given. + +The optional ZONE is omitted or nil for Emacs local time, t for +Universal Time, ‘wall’ for system wall clock time, or a string as +in the TZ environment variable." (cond ((string-match org-ts-regexp0 s) (list 0 - (if (or (match-beginning 8) (not nodefault)) - (string-to-number (or (match-string 8 s) "0"))) - (if (or (match-beginning 7) (not nodefault)) - (string-to-number (or (match-string 7 s) "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)) + nil nil zone)) ((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. (decode-time (seconds-to-time (org-matcher-time s)))) - (t (error "Not a standard Org-mode time string: %s" 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. @@ -17355,14 +18007,21 @@ With prefix ARG, change that many days." (org-timestamp-change (- (prefix-numeric-value arg)) 'day) 'updown)) (defun org-at-timestamp-p (&optional inactive-ok) - "Determine if the cursor is in or at a timestamp." + "Non-nil if point is inside a timestamp. + +When optional argument INACTIVE-OK is non-nil, also consider +inactive timestamps. + +When this function returns a non-nil value, match data is set +according to `org-ts-regexp3' or `org-ts-regexp2', depending on +INACTIVE-OK." (interactive) (let* ((tsr (if inactive-ok org-ts-regexp3 org-ts-regexp2)) (pos (point)) (ans (or (looking-at tsr) (save-excursion (skip-chars-backward "^[<\n\r\t") - (if (> (point) (point-min)) (backward-char 1)) + (when (> (point) (point-min)) (backward-char 1)) (and (looking-at tsr) (> (- (match-end 0) pos) -1)))))) (and ans @@ -17403,8 +18062,8 @@ With prefix ARG, change that many days." (defun org-at-clock-log-p nil "Is the cursor on the clock log line?" (save-excursion - (move-beginning-of-line 1) - (looking-at "^[ \t]*CLOCK:"))) + (beginning-of-line) + (looking-at org-clock-line-re))) (defvar org-clock-history) ; defined in org-clock.el (defvar org-clock-adjust-closest nil) ; defined in org-clock.el @@ -17420,19 +18079,19 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." org-ts-what extra rem ts time time0 fixnext clrgx) - (if (not (org-at-timestamp-p t)) - (user-error "Not at a timestamp")) + (unless (org-at-timestamp-p t) + (user-error "Not at a timestamp")) (if (and (not what) (eq org-ts-what 'bracket)) (org-toggle-timestamp-type) ;; Point isn't on brackets. Remember the part of the time-stamp ;; the point was in. Indeed, size of time-stamps may change, ;; but point must be kept in the same category nonetheless. (setq origin-cat org-ts-what) - (if (and (not what) (not (eq org-ts-what 'day)) - org-display-custom-times - (get-text-property (point) 'display) - (not (get-text-property (1- (point)) 'display))) - (setq org-ts-what 'day)) + (when (and (not what) (not (eq org-ts-what 'day)) + org-display-custom-times + (get-text-property (point) 'display) + (not (get-text-property (1- (point)) 'display))) + (setq org-ts-what 'day)) (setq org-ts-what (or what org-ts-what) inactive (= (char-after (match-beginning 0)) ?\[) ts (match-string 0)) @@ -17441,26 +18100,28 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." "\\(\\(-[012][0-9]:[0-5][0-9]\\)?\\( +[.+]?-?[-+][0-9]+[hdwmy]\\(/[0-9]+[hdwmy]\\)?\\)*\\)[]>]" ts) (setq extra (match-string 1 ts)) - (if suppress-tmp-delay - (setq extra (replace-regexp-in-string " --[0-9]+[hdwmy]" "" extra)))) - (if (string-match "^.\\{10\\}.*?[0-9]+:[0-9][0-9]" ts) - (setq with-hm t)) + (when suppress-tmp-delay + (setq extra (replace-regexp-in-string " --[0-9]+[hdwmy]" "" extra)))) + (when (string-match "^.\\{10\\}.*?[0-9]+:[0-9][0-9]" ts) + (setq with-hm t)) (setq time0 (org-parse-time-string ts)) (when (and updown (eq org-ts-what 'minute) (not current-prefix-arg)) ;; This looks like s-up and s-down. Change by one rounding step. (setq n (* dm (cond ((> n 0) 1) ((< n 0) -1) (t 0)))) - (when (not (= 0 (setq rem (% (nth 1 time0) dm)))) + (unless (= 0 (setq rem (% (nth 1 time0) dm))) (setcar (cdr time0) (+ (nth 1 time0) (if (> n 0) (- rem) (- dm rem)))))) (setq time - (encode-time (or (car time0) 0) - (+ (if (eq org-ts-what 'minute) n 0) (nth 1 time0)) - (+ (if (eq org-ts-what 'hour) n 0) (nth 2 time0)) - (+ (if (eq org-ts-what 'day) n 0) (nth 3 time0)) - (+ (if (eq org-ts-what 'month) n 0) (nth 4 time0)) - (+ (if (eq org-ts-what 'year) n 0) (nth 5 time0)))) + (apply #'encode-time + (or (car time0) 0) + (+ (if (eq org-ts-what 'minute) n 0) (nth 1 time0)) + (+ (if (eq org-ts-what 'hour) n 0) (nth 2 time0)) + (+ (if (eq org-ts-what 'day) n 0) (nth 3 time0)) + (+ (if (eq org-ts-what 'month) n 0) (nth 4 time0)) + (+ (if (eq org-ts-what 'year) n 0) (nth 5 time0)) + (nthcdr 6 time0))) (when (and (member org-ts-what '(hour minute)) extra (string-match "-\\([012][0-9]\\):\\([0-5][0-9]\\)" extra)) @@ -17470,15 +18131,15 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." n dm))) (when (integerp org-ts-what) (setq extra (org-modify-ts-extra extra org-ts-what n dm))) - (if (eq what 'calendar) - (let ((cal-date (org-get-date-from-calendar))) - (setcar (nthcdr 4 time0) (nth 0 cal-date)) ; month - (setcar (nthcdr 3 time0) (nth 1 cal-date)) ; day - (setcar (nthcdr 5 time0) (nth 2 cal-date)) ; year - (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 (apply 'encode-time time0)))) + (when (eq what 'calendar) + (let ((cal-date (org-get-date-from-calendar))) + (setcar (nthcdr 4 time0) (nth 0 cal-date)) ; month + (setcar (nthcdr 3 time0) (nth 1 cal-date)) ; day + (setcar (nthcdr 5 time0) (nth 2 cal-date)) ; year + (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 (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). @@ -17489,17 +18150,21 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." (goto-char pos)) (save-match-data (looking-at org-ts-regexp3) - (goto-char (cond - ;; `day' category ends before `hour' if any, or at - ;; the end of the day name. - ((eq origin-cat 'day) - (min (or (match-beginning 7) (1- (match-end 5))) origin)) - ((eq origin-cat 'hour) (min (match-end 7) origin)) - ((eq origin-cat 'minute) (min (1- (match-end 8)) origin)) - ((integerp origin-cat) (min (1- (match-end 0)) origin)) - ;; `year' and `month' have both fixed size: point - ;; couldn't have moved into another part. - (t origin)))) + (goto-char + (pcase origin-cat + ;; `day' category ends before `hour' if any, or at the end + ;; of the day name. + (`day (min (or (match-beginning 7) (1- (match-end 5))) origin)) + (`hour (min (match-end 7) origin)) + (`minute (min (1- (match-end 8)) origin)) + ((pred integerp) (min (1- (match-end 0)) origin)) + ;; Point was right after the time-stamp. However, the + ;; time-stamp length might have changed, so refer to + ;; (match-end 0) instead. + (`after (match-end 0)) + ;; `year' and `month' have both fixed size: point couldn't + ;; have moved into another part. + (_ origin)))) ;; Update clock if on a CLOCK line. (org-clock-update-time-maybe) ;; Maybe adjust the closest clock in `org-clock-history' @@ -17508,11 +18173,12 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." (< 1 (length (delq nil (mapcar 'marker-position org-clock-history)))))) (message "No clock to adjust") - (cond ((save-excursion ; fix previous clock? + (cond ((save-excursion ; fix previous clock? (re-search-backward org-ts-regexp0 nil t) - (org-looking-back (concat org-clock-string " \\["))) + (looking-back (concat org-clock-string " \\[") + (line-beginning-position))) (setq fixnext 1 clrgx (concat org-ts-regexp0 "\\] =>.*$"))) - ((save-excursion ; fix next clock? + ((save-excursion ; fix next clock? (re-search-backward org-ts-regexp0 nil t) (looking-at (concat org-ts-regexp0 "\\] =>"))) (setq fixnext -1 clrgx (concat org-clock-string " \\[" org-ts-regexp0)))) @@ -17521,8 +18187,8 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." (let* ((p (save-excursion (org-back-to-heading t))) (cl (mapcar (lambda(c) (abs (- (marker-position c) p))) org-clock-history)) (clfixnth - (+ fixnext (- (length cl) (or (length (member (apply #'min cl) cl)) 100)))) - (clfixpos (if (> 0 clfixnth) nil (nth clfixnth org-clock-history)))) + (+ fixnext (- (length cl) (or (length (member (apply 'min cl) cl)) 100)))) + (clfixpos (unless (> 0 clfixnth) (nth clfixnth org-clock-history)))) (if (not clfixpos) (message "No clock to adjust") (save-excursion @@ -17536,10 +18202,10 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." (file-name-nondirectory (buffer-file-name)) (org-get-heading t t))))))))) ;; Try to recenter the calendar window, if any. - (if (and org-calendar-follow-timestamp-change - (get-buffer-window "*Calendar*" t) - (memq org-ts-what '(day month year))) - (org-recenter-calendar (time-to-days time)))))) + (when (and org-calendar-follow-timestamp-change + (get-buffer-window "*Calendar*" t) + (memq org-ts-what '(day month year))) + (org-recenter-calendar (time-to-days time)))))) (defun org-modify-ts-extra (s pos n dm) "Change the different parts of the lead-time and repeat fields in timestamp." @@ -17553,13 +18219,13 @@ 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 (org-no-warnings (signum n)))) - (when (not (= 0 (setq rem (% m dm)))) + (setq n (* dm (with-no-warnings (signum n)))) + (unless (= 0 (setq rem (% m dm))) (setq m (+ m (if (> n 0) (- rem) (- dm rem))))) (setq m (+ m n))) - (if (< m 0) (setq m (+ m 60) h (1- h))) - (if (> m 59) (setq m (- m 60) h (1+ h))) - (setq h (min 24 (max 0 h))) + (when (< m 0) (setq m (+ m 60) h (1- h))) + (when (> m 59) (setq m (- m 60) h (1+ h))) + (setq h (mod h 24)) (setq ng 1 new (format "-%02d:%02d" h m))) ((org-pos-in-match-range pos 6) (setq ng 6 new (car (rassoc (+ n (cdr (assoc (match-string 6 s) idx))) idx)))) @@ -17578,14 +18244,14 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." (substring s (match-end ng)))))) s)) -(defun org-recenter-calendar (date) - "If the calendar is visible, recenter it to DATE." +(defun org-recenter-calendar (d) + "If the calendar is visible, recenter it to date D." (let ((cwin (get-buffer-window "*Calendar*" t))) (when cwin (let ((calendar-move-hook nil)) (with-selected-window cwin - (calendar-goto-date (if (listp date) date - (calendar-gregorian-from-absolute date)))))))) + (calendar-goto-date + (if (listp d) d (calendar-gregorian-from-absolute d)))))))) (defun org-goto-calendar (&optional arg) "Go to the Emacs calendar at the current date. @@ -17596,17 +18262,17 @@ A prefix ARG can be used to force the current date." (calendar-move-hook nil) (calendar-view-holidays-initially-flag nil) (calendar-view-diary-initially-flag nil)) - (if (or (org-at-timestamp-p) - (save-excursion - (beginning-of-line 1) - (looking-at (concat ".*" tsr)))) - (let ((d1 (time-to-days (current-time))) - (d2 (time-to-days - (org-time-string-to-time (match-string 1))))) - (setq diff (- d2 d1)))) + (when (or (org-at-timestamp-p) + (save-excursion + (beginning-of-line 1) + (looking-at (concat ".*" tsr)))) + (let ((d1 (time-to-days (current-time))) + (d2 (time-to-days + (org-time-string-to-time (match-string 1))))) + (setq diff (- d2 d1)))) (calendar) (calendar-goto-today) - (if (and diff (not arg)) (calendar-forward-day diff)))) + (when (and diff (not arg)) (calendar-forward-day diff)))) (defun org-get-date-from-calendar () "Return a list (month day year) of date at point in calendar." @@ -17625,7 +18291,8 @@ If there is already a time stamp at the cursor position, update it." (encode-time 0 0 0 (nth 1 cal-date) (car cal-date) (nth 2 cal-date)))))) (defcustom org-effort-durations - `(("h" . 60) + `(("min" . 1) + ("h" . 60) ("d" . ,(* 60 8)) ("w" . ,(* 60 8 5)) ("m" . ,(* 60 8 5 4)) @@ -17641,7 +18308,8 @@ 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 "24.1" + :version "26.1" + :package-version '(Org . "8.3") :type '(alist :key-type (string :tag "Modifier") :value-type (number :tag "Minutes"))) @@ -17734,10 +18402,6 @@ The format is determined by `org-time-clocksum-format', ;; return formatted time duration clocksum)))) -(defalias 'org-minutes-to-hh:mm-string 'org-minutes-to-clocksum-string) -(make-obsolete 'org-minutes-to-hh:mm-string 'org-minutes-to-clocksum-string - "Org mode version 8.0") - (defun org-hours-to-clocksum-string (n) (org-minutes-to-clocksum-string (* n 60))) @@ -17793,19 +18457,21 @@ tables are not re-aligned, etc." :version "24.3" :group 'org-agenda) -(defcustom org-agenda-ignore-drawer-properties nil +(defcustom org-agenda-ignore-properties nil "Avoid updating text properties when building the agenda. -Properties are used to prepare buffers for effort estimates, appointments, -and subtree-local categories. -If you don't use these in the agenda, you can add them to this list and -agenda building will be a bit faster. +Properties are used to prepare buffers for effort estimates, +appointments, statistics and subtree-local categories. +If you don't use these in the agenda, you can add them to this +list and agenda building will be a bit faster. The value is a list, with zero or more of the symbols `effort', `appt', -or `category'." +`stats' or `category'." :type '(set :greedy t (const effort) (const appt) + (const stats) (const category)) - :version "24.3" + :version "26.1" + :package-version '(Org . "8.3") :group 'org-agenda) (defun org-duration-string-to-minutes (s &optional output-to-string) @@ -17821,25 +18487,25 @@ Entries containing a colon are interpreted as H:MM by (regexp-opt (mapcar 'car org-effort-durations)) "\\)"))) (while (string-match re s) - (incf result (* (cdr (assoc (match-string 2 s) org-effort-durations)) - (string-to-number (match-string 1 s)))) + (cl-incf result (* (cdr (assoc (match-string 2 s) org-effort-durations)) + (string-to-number (match-string 1 s)))) (setq s (replace-match "" nil t s))) (setq result (floor result)) - (incf result (org-hh:mm-string-to-minutes s)) + (cl-incf result (org-hh:mm-string-to-minutes s)) (if output-to-string (number-to-string result) result))) ;;;; Files (defun org-save-all-org-buffers () - "Save all Org-mode buffers without user confirmation." + "Save all Org buffers without user confirmation." (interactive) - (message "Saving all Org-mode buffers...") + (message "Saving all Org buffers...") (save-some-buffers t (lambda () (derived-mode-p 'org-mode))) (when (featurep 'org-id) (org-id-locations-save)) - (message "Saving all Org-mode buffers... done")) + (message "Saving all Org buffers... done")) (defun org-revert-all-org-buffers () - "Revert all Org-mode buffers. + "Revert all Org buffers. Prompt for confirmation when there are unsaved changes. Be sure you know what you are doing before letting this function overwrite your changes. @@ -17856,13 +18522,11 @@ changes from another. I believe the procedure must be like this: (user-error "Abort")) (save-excursion (save-window-excursion - (mapc - (lambda (b) - (when (and (with-current-buffer b (derived-mode-p 'org-mode)) - (with-current-buffer b buffer-file-name)) - (org-pop-to-buffer-same-window b) - (revert-buffer t 'no-confirm))) - (buffer-list)) + (dolist (b (buffer-list)) + (when (and (with-current-buffer b (derived-mode-p 'org-mode)) + (with-current-buffer b buffer-file-name)) + (pop-to-buffer-same-window b) + (revert-buffer t 'no-confirm))) (when (and (featurep 'org-id) org-id-track-globally) (org-id-locations-load))))) @@ -17871,29 +18535,19 @@ changes from another. I believe the procedure must be like this: ;;;###autoload (defun org-switchb (&optional arg) "Switch between Org buffers. -With one prefix argument, restrict available buffers to files. -With two prefix arguments, restrict available buffers to agenda files. -Defaults to `iswitchb' for buffer name completion. -Set `org-completion-use-ido' to make it use ido instead." +With `\\[universal-argument]' prefix, restrict available buffers to files. + +With `\\[universal-argument] \\[universal-argument]' \ +prefix, restrict available buffers to agenda files." (interactive "P") - (let ((blist (cond ((equal arg '(4)) (org-buffer-list 'files)) - ((equal arg '(16)) (org-buffer-list 'agenda)) - (t (org-buffer-list)))) - (org-completion-use-iswitchb org-completion-use-iswitchb) - (org-completion-use-ido org-completion-use-ido)) - (unless (or org-completion-use-ido org-completion-use-iswitchb) - (setq org-completion-use-iswitchb t)) - (org-pop-to-buffer-same-window - (org-icompleting-read "Org buffer: " - (mapcar 'list (mapcar 'buffer-name blist)) - nil t)))) - -;;; Define some older names previously used for this functionality -;;;###autoload -(defalias 'org-ido-switchb 'org-switchb) -;;;###autoload -(defalias 'org-iswitchb 'org-switchb) + (let ((blist (org-buffer-list + (cond ((equal arg '(4)) 'files) + ((equal arg '(16)) 'agenda))))) + (pop-to-buffer-same-window + (completing-read "Org buffer: " + (mapcar #'list (mapcar #'buffer-name blist)) + nil t)))) (defun org-buffer-list (&optional predicate exclude-tmp) "Return a list of Org buffers. @@ -17968,8 +18622,10 @@ used by the agenda files. If ARCHIVE is `ifmode', do this only if "Return non-nil, if FILE is an agenda file. If FILE is omitted, use the file associated with the current buffer." - (member (or file (buffer-file-name)) - (org-agenda-files t))) + (let ((fname (or file (buffer-file-name)))) + (and fname + (member (file-truename fname) + (mapcar #'file-truename (org-agenda-files t)))))) (defun org-edit-agenda-file-list () "Edit the list of agenda files. @@ -17981,15 +18637,15 @@ the buffer and restores the previous window configuration." (if (stringp org-agenda-files) (let ((cw (current-window-configuration))) (find-file org-agenda-files) - (org-set-local 'org-window-configuration cw) - (org-add-hook 'after-save-hook - (lambda () - (set-window-configuration - (prog1 org-window-configuration - (kill-buffer (current-buffer)))) - (org-install-agenda-files-menu) - (message "New agenda file list installed")) - nil 'local) + (setq-local org-window-configuration cw) + (add-hook 'after-save-hook + (lambda () + (set-window-configuration + (prog1 org-window-configuration + (kill-buffer (current-buffer)))) + (org-install-agenda-files-menu) + (message "New agenda file list installed")) + nil 'local) (message "%s" (substitute-command-keys "Edit list and finish with \\[save-buffer]"))) (customize-variable 'org-agenda-files))) @@ -18039,19 +18695,16 @@ un-expanded file names." If the current buffer visits an agenda file, find the next one in the list. If the current buffer does not, find the first agenda file." (interactive) - (let* ((fs (org-agenda-files t)) - (files (append fs (list (car fs)))) - (tcf (if buffer-file-name (file-truename buffer-file-name))) + (let* ((fs (or (org-agenda-files t) + (user-error "No agenda files"))) + (files (copy-sequence fs)) + (tcf (and buffer-file-name (file-truename buffer-file-name))) file) - (unless files (user-error "No agenda files")) - (catch 'exit - (dolist (file files) - (if (equal (file-truename file) tcf) - (when (car files) - (find-file (car files)) - (throw 'exit t)))) - (find-file (car fs))) - (if (buffer-base-buffer) (org-pop-to-buffer-same-window (buffer-base-buffer))))) + (when tcf + (while (and (setq file (pop files)) + (not (equal (file-truename file) tcf))))) + (find-file (car (or files fs))) + (when (buffer-base-buffer) (pop-to-buffer-same-window (buffer-base-buffer))))) (defun org-agenda-file-to-front (&optional to-end) "Move/add the current file to the top of the agenda file list. @@ -18069,7 +18722,7 @@ end of the list." x had) (setq x (assoc ctf file-alist) had x) - (if (not x) (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) + (unless x (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) (if to-end (setq file-alist (append (delq x file-alist) (list x))) (setq file-alist (cons x (delq x file-alist)))) @@ -18090,15 +18743,15 @@ Optional argument FILE means use this file instead of the current." (afile (abbreviate-file-name file)) (files (delq nil (mapcar (lambda (x) - (if (equal true-file - (file-truename x)) - nil x)) + (unless (equal true-file + (file-truename x)) + x)) (org-agenda-files t))))) (if (not (= (length files) (length (org-agenda-files t)))) (progn (org-store-new-agenda-file-list files) (org-install-agenda-files-menu) - (message "Removed file: %s" afile)) + (message "Removed from Org Agenda list: %s" afile)) (message "File was not in list: %s (not removed)" afile)))) (defun org-file-menu-entry (file) @@ -18106,7 +18759,7 @@ Optional argument FILE means use this file instead of the current." (defun org-check-agenda-file (file) "Make sure FILE exists. If not, ask user what to do." - (when (not (file-exists-p file)) + (unless (file-exists-p file) (message "Non-existent agenda file %s. [R]emove from list or [A]bort?" (abbreviate-file-name file)) (let ((r (downcase (read-char-exclusive)))) @@ -18114,17 +18767,18 @@ Optional argument FILE means use this file instead of the current." ((equal r ?r) (org-remove-file file) (throw 'nextfile t)) - (t (error "Abort")))))) + (t (user-error "Abort")))))) (defun org-get-agenda-file-buffer (file) - "Get a buffer visiting FILE. If the buffer needs to be created, add -it to the list of buffers which might be released later." + "Get an agenda buffer visiting FILE. +If the buffer needs to be created, add it to the list of buffers +which might be released later." (let ((buf (org-find-base-buffer-visiting file))) (if buf buf ; just return it ;; Make a new buffer and remember it (setq buf (find-file-noselect file)) - (if buf (push buf org-agenda-new-buffers)) + (when buf (push buf org-agenda-new-buffers)) buf))) (defun org-release-buffers (blist) @@ -18149,7 +18803,7 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (inhibit-read-only t) (org-inhibit-startup org-agenda-inhibit-startup) (rea (concat ":" org-archive-tag ":")) - file re pos) + re pos) (setq org-tag-alist-for-agenda nil org-tag-groups-alist-for-agenda nil) (save-excursion @@ -18161,20 +18815,15 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (org-check-agenda-file file) (set-buffer (org-get-agenda-file-buffer file))) (widen) - (org-set-regexps-and-options-for-tags) + (org-set-regexps-and-options 'tags-only) (setq pos (point)) - (goto-char (point-min)) - (let ((case-fold-search t)) - (when (search-forward "#+setupfile" nil t) - ;; Don't set all regexps and options systematically as - ;; this is only run for setting agenda tags from setup - ;; file - (org-set-regexps-and-options))) - (or (memq 'category org-agenda-ignore-drawer-properties) + (or (memq 'category org-agenda-ignore-properties) (org-refresh-category-properties)) - (or (memq 'effort org-agenda-ignore-drawer-properties) - (org-refresh-properties org-effort-property 'org-effort)) - (or (memq 'appt org-agenda-ignore-drawer-properties) + (or (memq 'stats org-agenda-ignore-properties) + (org-refresh-stats-properties)) + (or (memq 'effort org-agenda-ignore-properties) + (org-refresh-effort-properties)) + (or (memq 'appt org-agenda-ignore-properties) (org-refresh-properties "APPT_WARNTIME" 'org-appt-warntime)) (setq org-todo-keywords-for-agenda (append org-todo-keywords-for-agenda org-todo-keywords-1)) @@ -18182,31 +18831,32 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (append org-done-keywords-for-agenda org-done-keywords)) (setq org-todo-keyword-alist-for-agenda (append org-todo-keyword-alist-for-agenda org-todo-key-alist)) - (setq org-drawers-for-agenda - (append org-drawers-for-agenda org-drawers)) (setq org-tag-alist-for-agenda (org-uniquify (append org-tag-alist-for-agenda - org-tag-alist - org-tag-persistent-alist))) - (if org-group-tags - (setq org-tag-groups-alist-for-agenda - (org-uniquify-alist - (append org-tag-groups-alist-for-agenda org-tag-groups-alist)))) + org-current-tag-alist))) + ;; Merge current file's tag groups into global + ;; `org-tag-groups-alist-for-agenda'. + (when org-group-tags + (dolist (alist org-tag-groups-alist) + (let ((old (assoc (car alist) org-tag-groups-alist-for-agenda))) + (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) - (if (org-at-heading-p t) - (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) + (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 org-heading-keyword-regexp-format - org-comment-string)) + (setq re (format "^\\*+ .*\\<%s\\>" org-comment-string)) (while (re-search-forward re nil t) - (add-text-properties - (match-beginning 0) (org-end-of-subtree t) pc)))) + (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)) @@ -18223,7 +18873,7 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (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{" 'cdlatex-environment) +(org-defkey org-cdlatex-mode-map "\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.") @@ -18231,7 +18881,7 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (define-minor-mode org-cdlatex-mode "Toggle the minor `org-cdlatex-mode'. This mode supports entering LaTeX environment and math in LaTeX fragments -in Org-mode. +in Org mode. \\{org-cdlatex-mode-map}" nil " OCDL" nil (when org-cdlatex-mode @@ -18241,11 +18891,11 @@ in Org-mode. (unless org-cdlatex-texmathp-advice-is-done (setq org-cdlatex-texmathp-advice-is-done t) (defadvice texmathp (around org-math-always-on activate) - "Always return t in org-mode buffers. + "Always return t in Org buffers. This is because we want to insert math symbols without dollars even outside -the LaTeX math segments. If Orgmode thinks that point is actually inside -an embedded LaTeX fragment, let texmathp do its job. -\\[org-cdlatex-mode-map]" +the LaTeX math segments. If Org mode thinks that point is actually inside +an embedded LaTeX fragment, let `texmathp' do its job. +`\\[org-cdlatex-mode-map]'" (interactive) (let (p) (cond @@ -18257,8 +18907,8 @@ an embedded LaTeX fragment, let texmathp do its job. (let ((p (org-inside-LaTeX-fragment-p))) (if (and p (member (car p) (plist-get org-format-latex-options :matchers))) (setq ad-return-value t - texmathp-why '("Org-mode embedded math" . 0)) - (if p ad-do-it))))))))) + texmathp-why '("Org mode embedded math" . 0)) + (when p ad-do-it))))))))) (defun turn-on-org-cdlatex () "Unconditionally turn on `org-cdlatex-mode'." @@ -18283,7 +18933,7 @@ It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is (cdlatex-tab) t) ((org-inside-LaTeX-fragment-p) (cdlatex-tab) t)))) -(defun org-cdlatex-underscore-caret (&optional arg) +(defun org-cdlatex-underscore-caret (&optional _arg) "Execute `cdlatex-sub-superscript' in LaTeX fragments. Revert to the normal definition outside of these fragments." (interactive "P") @@ -18292,7 +18942,7 @@ Revert to the normal definition outside of these fragments." (let (org-cdlatex-mode) (call-interactively (key-binding (vector last-input-event)))))) -(defun org-cdlatex-math-modify (&optional arg) +(defun org-cdlatex-math-modify (&optional _arg) "Execute `cdlatex-math-modify' in LaTeX fragments. Revert to the normal definition outside of these fragments." (interactive "P") @@ -18301,21 +18951,66 @@ Revert to the normal definition outside of these fragments." (let (org-cdlatex-mode) (call-interactively (key-binding (vector last-input-event)))))) +(defun org-cdlatex-environment-indent (&optional environment item) + "Execute `cdlatex-environment' and indent the inserted environment. + +ENVIRONMENT and ITEM are passed to `cdlatex-environment'. + +The inserted environment is indented to current indentation +unless point is at the beginning of the line, in which the +environment remains unintended." + (interactive) + ;; cdlatex-environment always return nil. Therefore, capture output + ;; first and determine if an environment was selected. + (let* ((beg (point-marker)) + (end (copy-marker (point) t)) + (inserted (progn + (ignore-errors (cdlatex-environment environment item)) + (< beg end))) + ;; Figure out how many lines to move forward after the + ;; environment has been inserted. + (lines (when inserted + (save-excursion + (- (cl-loop while (< beg (point)) + with x = 0 + do (forward-line -1) + (cl-incf x) + finally return x) + (if (progn (goto-char beg) + (and (progn (skip-chars-forward " \t") (eolp)) + (progn (skip-chars-backward " \t") (bolp)))) + 1 0))))) + (env (org-trim (delete-and-extract-region beg end)))) + (when inserted + ;; Get indentation of next line unless at column 0. + (let ((ind (if (bolp) 0 + (save-excursion + (org-return-indent) + (prog1 (org-get-indentation) + (when (progn (skip-chars-forward " \t") (eolp)) + (delete-region beg (point))))))) + (bol (progn (skip-chars-backward " \t") (bolp)))) + ;; Insert a newline before environment unless at column zero + ;; to "escape" the current line. Insert a newline if + ;; something is one the same line as \end{ENVIRONMENT}. + (insert + (concat (unless bol "\n") env + (when (and (skip-chars-forward " \t") (not (eolp))) "\n"))) + (unless (zerop ind) + (save-excursion + (goto-char beg) + (while (< (point) end) + (unless (eolp) (indent-line-to ind)) + (forward-line)))) + (goto-char beg) + (forward-line lines) + (indent-line-to ind))) + (set-marker beg nil) + (set-marker end nil))) ;;;; LaTeX fragments -(defvar org-latex-regexps - '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) - ;; ("$" "\\([ (]\\|^\\)\\(\\(\\([$]\\)\\([^ \r\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \r\n,.$]\\)\\4\\)\\)\\([ .,?;:'\")]\\|$\\)" 2 nil) - ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p - ("$1" "\\([^$]\\|^\\)\\(\\$[^ \r\n,;.$]\\$\\)\\([- .,?;:'\")\000]\\|$\\)" 2 nil) - ("$" "\\([^$]\\|^\\)\\(\\(\\$\\([^ \r\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \r\n,.$]\\)\\$\\)\\)\\([- .,?;:'\")\000]\\|$\\)" 2 nil) - ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) - ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 nil) - ("$$" "\\$\\$[^\000]*?\\$\\$" 0 nil)) - "Regular expressions for matching embedded LaTeX.") - (defun org-inside-LaTeX-fragment-p () "Test if point is inside a LaTeX fragment. I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing @@ -18358,7 +19053,7 @@ looks only before point, not after." (while (re-search-backward "\\$\\$" lim t) (setq dd-on (not dd-on))) (goto-char pos) - (if dd-on (cons "$$" m)))))) + (when dd-on (cons "$$" m)))))) (defun org-inside-latex-macro-p () "Is point inside a LaTeX macro or its arguments?" @@ -18366,179 +19061,226 @@ looks only before point, not after." (org-in-regexp "\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*"))) -(defvar org-latex-fragment-image-overlays nil - "List of overlays carrying the images of latex fragments.") -(make-variable-buffer-local 'org-latex-fragment-image-overlays) +(defun org--format-latex-make-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\"." + (let ((ov (make-overlay beg end)) + (imagetype (or (intern imagetype) 'png))) + (overlay-put ov 'org-overlay-type 'org-latex-overlay) + (overlay-put ov 'evaporate t) + (overlay-put ov + 'modification-hooks + (list (lambda (o _flag _beg _end &optional _l) + (delete-overlay o)))) + (overlay-put ov + '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) + "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))) + (mapc #'delete-overlay overlays) + overlays)) + +(defun org-toggle-latex-fragment (&optional arg) + "Preview the LaTeX fragment at point, or all locally or globally. -(defun org-remove-latex-fragment-image-overlays () - "Remove all overlays with LaTeX fragment images in current buffer." - (mapc 'delete-overlay org-latex-fragment-image-overlays) - (setq org-latex-fragment-image-overlays nil)) +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-preview-latex-fragment (&optional subtree) - "Preview the LaTeX fragment at point, or all locally or globally. -If the cursor is in a LaTeX fragment, create the image and overlay -it over the source code. If there is no fragment at point, display -all fragments in the current text, from one headline to the next. With -prefix SUBTREE, display all fragments in the current subtree. With a -double prefix arg \\[universal-argument] \\[universal-argument], or when \ -the cursor is before the first headline, -display all fragments in the buffer. -The images can be removed again with \\[org-ctrl-c-ctrl-c]." +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." (interactive "P") - (unless buffer-file-name - (user-error "Can't preview LaTeX fragment in a non-file buffer")) (when (display-graphic-p) - (org-remove-latex-fragment-image-overlays) - (save-excursion - (save-restriction - (let (beg end at msg) + (catch 'exit + (save-excursion + (let (beg end msg) (cond - ((or (equal subtree '(16)) - (not (save-excursion - (re-search-backward org-outline-regexp-bol nil t)))) - (setq beg (point-min) end (point-max) - msg "Creating images for buffer...%s")) - ((equal subtree '(4)) - (org-back-to-heading) - (setq beg (point) end (org-end-of-subtree t) - msg "Creating images for subtree...%s")) + ((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 - (if (setq at (org-inside-LaTeX-fragment-p)) - (goto-char (max (point-min) (- (cdr at) 2))) - (org-back-to-heading)) - (setq beg (point) end (progn (outline-next-heading) (point)) - msg (if at "Creating image...%s" - "Creating images for entry...%s")))) - (message msg "") - (narrow-to-region beg end) - (goto-char beg) - (org-format-latex - (concat org-latex-preview-ltxpng-directory (file-name-sans-extension - (file-name-nondirectory - buffer-file-name))) - default-directory 'overlays msg at 'forbuffer - org-latex-create-formula-image-program) - (message msg "done. Use `C-c C-c' to remove images.")))))) - -(defun org-format-latex (prefix &optional dir overlays msg at - forbuffer processing-type) - "Replace LaTeX fragments with links to an image, and produce images. + (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"))))))) + +(defun org-format-latex + (prefix &optional beg end dir overlays msg forbuffer processing-type) + "Replace LaTeX fragments with links to an image. + +The function takes care of creating the replacement image. + +Only consider fragments between BEG and END when those are +provided. + +When optional argument OVERLAYS is non-nil, display the image on +top of the fragment instead of replacing it. + +PROCESSING-TYPE is the conversion method to use, as a symbol. + Some of the options can be changed using the variable -`org-format-latex-options'." - (if (and overlays (fboundp 'clear-image-cache)) (clear-image-cache)) - (let* ((prefixnodir (file-name-nondirectory prefix)) - (absprefix (expand-file-name prefix dir)) - (todir (file-name-directory absprefix)) - (opt org-format-latex-options) - (optnew org-format-latex-options) - (matchers (plist-get opt :matchers)) - (re-list org-latex-regexps) - (cnt 0) txt hash link beg end re checkdir - string - m n block-type block linkfile movefile ov) - ;; Check the different regular expressions - (dolist (e re-list) - (setq m (car e) re (nth 1 e) n (nth 2 e) block-type (nth 3 e) - block (if block-type "\n\n" "")) - (when (member m matchers) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (when (and (or (not at) (equal (cdr at) (match-beginning n))) - (or (not overlays) - (not (eq (get-char-property (match-beginning n) - 'org-overlay-type) - 'org-latex-overlay)))) - (cond - ((eq processing-type 'verbatim)) - ((eq processing-type 'mathjax) - ;; Prepare for MathJax processing. - (setq string (match-string n)) - (when (member m '("$" "$1")) - (save-excursion - (delete-region (match-beginning n) (match-end n)) - (goto-char (match-beginning n)) - (insert (concat "\\(" (substring string 1 -1) "\\)"))))) - ((or (eq processing-type 'dvipng) - (eq processing-type 'imagemagick)) - ;; Process to an image. - (setq txt (match-string n) - beg (match-beginning n) end (match-end n) - cnt (1+ cnt)) - (let ((face (face-at-point)) - (fg (plist-get opt :foreground)) - (bg (plist-get opt :background)) - ;; Ensure full list is printed. - print-length print-level) - (when forbuffer - ;; Get the colors from the face at point. +`org-format-latex-options', which see." + (when (and overlays (fboundp 'clear-image-cache)) (clear-image-cache)) + (unless (eq processing-type 'verbatim) + (let* ((math-regexp "\\$\\|\\\\[([]\\|^[ \t]*\\\\begin{[A-Za-z0-9*]+}") + (cnt 0) + checkdir-flag) + (goto-char (or beg (point-min))) + ;; Optimize overlay creation: (info "(elisp) Managing Overlays"). + (when (and overlays (memq processing-type '(dvipng imagemagick))) + (overlay-recenter (or end (point-max)))) + (while (re-search-forward math-regexp end t) + (unless (and overlays + (eq (get-char-property (point) 'org-overlay-type) + 'org-latex-overlay)) + (let* ((context (org-element-context)) + (type (org-element-type context))) + (when (memq type '(latex-environment latex-fragment)) + (let ((block-type (eq type 'latex-environment)) + (value (org-element-property :value context)) + (beg (org-element-property :begin context)) + (end (save-excursion + (goto-char (org-element-property :end context)) + (skip-chars-backward " \r\t\n") + (point)))) + (cond + ((eq processing-type 'mathjax) + ;; Prepare for MathJax processing. + (if (not (string-match "\\`\\$\\$?" value)) + (goto-char end) + (delete-region beg end) + (if (string= (match-string 0 value) "$$") + (insert "\\[" (substring value 2 -2) "\\]") + (insert "\\(" (substring value 1 -1) "\\)")))) + ((assq processing-type org-preview-latex-process-alist) + ;; Process to an image. + (cl-incf cnt) (goto-char beg) - (when (eq fg 'auto) - (setq fg (face-attribute face :foreground nil 'default))) - (when (eq bg 'auto) - (setq bg (face-attribute face :background nil 'default))) - (setq optnew (copy-sequence opt)) - (plist-put optnew :foreground fg) - (plist-put optnew :background bg)) - (setq hash (sha1 (prin1-to-string - (list org-format-latex-header - org-latex-default-packages-alist - org-latex-packages-alist - org-format-latex-options - forbuffer txt fg bg))) - linkfile (format "%s_%s.png" prefix hash) - movefile (format "%s_%s.png" absprefix hash))) - (setq link (concat block "[[file:" linkfile "]]" block)) - (if msg (message msg cnt)) - (goto-char beg) - (unless checkdir ; Ensure the directory exists. - (setq checkdir t) - (or (file-directory-p todir) (make-directory todir t))) - (unless (file-exists-p movefile) - (org-create-formula-image - txt movefile optnew forbuffer processing-type)) - (if overlays - (progn - (mapc (lambda (o) - (if (eq (overlay-get o 'org-overlay-type) - 'org-latex-overlay) - (delete-overlay o))) - (overlays-in beg end)) - (setq ov (make-overlay beg end)) - (overlay-put ov 'org-overlay-type 'org-latex-overlay) - (if (featurep 'xemacs) + (let* ((processing-info + (cdr (assq processing-type org-preview-latex-process-alist))) + (face (face-at-point)) + ;; Get the colors from the face at point. + (fg + (let ((color (plist-get org-format-latex-options + :foreground))) + (if (and forbuffer (eq color 'auto)) + (face-attribute face :foreground nil 'default) + color))) + (bg + (let ((color (plist-get org-format-latex-options + :background))) + (if (and forbuffer (eq color 'auto)) + (face-attribute face :background nil 'default) + color))) + (hash (sha1 (prin1-to-string + (list org-format-latex-header + org-latex-default-packages-alist + org-latex-packages-alist + org-format-latex-options + forbuffer value fg bg)))) + (imagetype (or (plist-get processing-info :image-output-type) "png")) + (absprefix (expand-file-name prefix dir)) + (linkfile (format "%s_%s.%s" prefix hash imagetype)) + (movefile (format "%s_%s.%s" absprefix hash imagetype)) + (sep (and block-type "\n\n")) + (link (concat sep "[[file:" linkfile "]]" sep)) + (options + (org-combine-plists + org-format-latex-options + `(:foreground ,fg :background ,bg)))) + (when msg (message msg cnt)) + (unless checkdir-flag ; Ensure the directory exists. + (setq checkdir-flag t) + (let ((todir (file-name-directory absprefix))) + (unless (file-directory-p todir) + (make-directory todir t)))) + (unless (file-exists-p movefile) + (org-create-formula-image + value movefile options forbuffer processing-type)) + (if overlays (progn - (overlay-put ov 'invisible t) - (overlay-put - ov 'end-glyph - (make-glyph (vector 'png :file movefile)))) - (overlay-put - ov 'display - (list 'image :type 'png :file movefile :ascent 'center))) - (push ov org-latex-fragment-image-overlays) - (goto-char end)) - (delete-region beg end) - (insert (org-add-props link - (list 'org-latex-src - (replace-regexp-in-string - "\"" "" txt) - 'org-latex-src-embed-type - (if block-type 'paragraph 'character)))))) - ((eq processing-type 'mathml) - ;; Process to MathML - (unless (save-match-data (org-format-latex-mathml-available-p)) - (user-error "LaTeX to MathML converter not configured")) - (setq txt (match-string n) - beg (match-beginning n) end (match-end n) - cnt (1+ cnt)) - (if msg (message msg cnt)) - (goto-char beg) - (delete-region beg end) - (insert (org-format-latex-as-mathml - txt block-type prefix dir))) - (t - (error "Unknown conversion type %s for LaTeX fragments" - processing-type))))))))) + (dolist (o (overlays-in beg end)) + (when (eq (overlay-get o 'org-overlay-type) + 'org-latex-overlay) + (delete-overlay o))) + (org--format-latex-make-overlay beg end movefile imagetype) + (goto-char end)) + (delete-region beg end) + (insert + (org-add-props link + (list 'org-latex-src + (replace-regexp-in-string "\"" "" value) + 'org-latex-src-embed-type + (if block-type 'paragraph 'character))))))) + ((eq processing-type 'mathml) + ;; Process to MathML. + (unless (org-format-latex-mathml-available-p) + (user-error "LaTeX to MathML converter not configured")) + (cl-incf cnt) + (when msg (message msg cnt)) + (goto-char beg) + (delete-region beg end) + (insert (org-format-latex-as-mathml + value block-type prefix dir))) + (t + (error "Unknown conversion process %s for LaTeX fragments" + processing-type))))))))))) (defun org-create-math-formula (latex-frag &optional mathml-file) "Convert LATEX-FRAG to MathML and store it in MATHML-FILE. @@ -18553,20 +19295,25 @@ inspection." (buffer-substring-no-properties (region-beginning) (region-end))))) (read-string "LaTeX Fragment: " frag nil frag)))) - (unless latex-frag (error "Invalid LaTeX fragment")) - (let* ((tmp-in-file (file-relative-name - (make-temp-name (expand-file-name "ltxmathml-in")))) - (ignore (write-region latex-frag nil tmp-in-file)) + (unless latex-frag (user-error "Invalid LaTeX fragment")) + (let* ((tmp-in-file + (let ((file (file-relative-name + (make-temp-name (expand-file-name "ltxmathml-in"))))) + (write-region latex-frag nil file) + file)) (tmp-out-file (file-relative-name (make-temp-name (expand-file-name "ltxmathml-out")))) (cmd (format-spec org-latex-to-mathml-convert-command - `((?j . ,(shell-quote-argument - (expand-file-name org-latex-to-mathml-jar-file))) + `((?j . ,(and org-latex-to-mathml-jar-file + (shell-quote-argument + (expand-file-name + org-latex-to-mathml-jar-file)))) (?I . ,(shell-quote-argument tmp-in-file)) + (?i . ,latex-frag) (?o . ,(shell-quote-argument tmp-out-file))))) mathml shell-command-output) - (when (org-called-interactively-p 'any) + (when (called-interactively-p 'any) (unless (org-format-latex-mathml-available-p) (user-error "LaTeX to MathML converter not configured"))) (message "Running %s" cmd) @@ -18576,11 +19323,10 @@ inspection." (with-current-buffer (find-file-noselect tmp-out-file t) (goto-char (point-min)) (when (re-search-forward - (concat - (regexp-quote - "<math xmlns=\"http://www.w3.org/1998/Math/MathML\">") - "\\(.\\|\n\\)*" - (regexp-quote "</math>")) nil t) + (format "<math[^>]*?%s[^>]*?>\\(.\\|\n\\)*</math>" + (regexp-quote + "xmlns=\"http://www.w3.org/1998/Math/MathML\"")) + nil t) (prog1 (match-string 0) (kill-buffer)))))) (cond (mathml @@ -18588,7 +19334,7 @@ inspection." (concat "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" mathml)) (when mathml-file (write-region mathml nil mathml-file)) - (when (org-called-interactively-p 'any) + (when (called-interactively-p 'any) (message mathml))) ((message "LaTeX to MathML conversion failed") (message shell-command-output))) @@ -18627,186 +19373,117 @@ inspection." ;; Failed conversion. Return the LaTeX fragment verbatim latex-frag))) -(defun org-create-formula-image (string tofile options buffer &optional type) - "Create an image from LaTeX source using dvipng or convert. -This function calls either `org-create-formula-image-with-dvipng' -or `org-create-formula-image-with-imagemagick' depending on the -value of `org-latex-create-formula-image-program' or on the value -of the optional TYPE variable. - -Note: ultimately these two function should be combined as they -share a good deal of logic." - (org-check-external-command - "latex" "needed to convert LaTeX fragments to images") - (funcall - (case (or type org-latex-create-formula-image-program) - ('dvipng - (org-check-external-command - "dvipng" "needed to convert LaTeX fragments to images") - #'org-create-formula-image-with-dvipng) - ('imagemagick - (org-check-external-command - "convert" "you need to install imagemagick") - #'org-create-formula-image-with-imagemagick) - (t (error - "Invalid value of `org-latex-create-formula-image-program'"))) - string tofile options buffer)) - -(declare-function org-export-get-backend "ox" (name)) -(declare-function org-export--get-global-options "ox" (&optional backend)) -(declare-function org-export--get-inbuffer-options "ox" (&optional backend)) -(declare-function org-latex-guess-inputenc "ox-latex" (header)) -(declare-function org-latex-guess-babel-language "ox-latex" (header info)) -(defun org-create-formula--latex-header () - "Return LaTeX header appropriate for previewing a LaTeX snippet." - (let ((info (org-combine-plists (org-export--get-global-options - (org-export-get-backend 'latex)) - (org-export--get-inbuffer-options - (org-export-get-backend 'latex))))) - (org-latex-guess-babel-language - (org-latex-guess-inputenc - (org-splice-latex-header - org-format-latex-header - org-latex-default-packages-alist - org-latex-packages-alist t - (plist-get info :latex-header))) - info))) - -;; This function borrows from Ganesh Swami's latex2png.el -(defun org-create-formula-image-with-dvipng (string tofile options buffer) - "This calls dvipng." - (require 'ox-latex) - (let* ((tmpdir (if (featurep 'xemacs) - (temp-directory) - temporary-file-directory)) +(defun org--get-display-dpi () + "Get the DPI of the display. +The function assumes that the display has the same pixel width in +the horizontal and vertical directions." + (if (display-graphic-p) + (round (/ (display-pixel-height) + (/ (display-mm-height) 25.4))) + (error "Attempt to calculate the dpi of a non-graphic display"))) + +(defun org-create-formula-image + (string tofile options buffer &optional processing-type) + "Create an image from LaTeX source using external processes. + +The LaTeX STRING is saved to a temporary LaTeX file, then +converted to an image file by process PROCESSING-TYPE defined in +`org-preview-latex-process-alist'. A nil value defaults to +`org-preview-latex-default-process'. + +The generated image file is eventually moved to TOFILE. + +The OPTIONS argument controls the size, foreground color and +background color of the generated image. + +When BUFFER non-nil, this function is used for LaTeX previewing. +Otherwise, it is used to deal with LaTeX snippets showed in +a HTML file." + (let* ((processing-type (or processing-type + org-preview-latex-default-process)) + (processing-info + (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) + '(".dvi" ".xdv" ".pdf" ".tex" ".aux" ".log" + ".svg" ".png" ".jpg" ".jpeg" ".out"))) + (latex-header + (or (plist-get processing-info :latex-header) + (org-latex-make-preamble + (org-export-get-environment (org-export-get-backend 'latex)) + org-format-latex-header + 'snippet))) + (latex-compiler (plist-get processing-info :latex-compiler)) + (image-converter (plist-get processing-info :image-converter)) + (tmpdir temporary-file-directory) (texfilebase (make-temp-name (expand-file-name "orgtex" tmpdir))) (texfile (concat texfilebase ".tex")) - (dvifile (concat texfilebase ".dvi")) - (pngfile (concat texfilebase ".png")) - (fnh (if (featurep 'xemacs) - (font-height (face-font 'default)) - (face-attribute 'default :height nil))) - (scale (or (plist-get options (if buffer :scale :html-scale)) 1.0)) - (dpi (number-to-string (* scale (floor (* 0.9 (if buffer fnh 140.)))))) + (image-size-adjust (or (plist-get processing-info :image-size-adjust) + '(1.0 . 1.0))) + (scale (* (if buffer (car image-size-adjust) (cdr image-size-adjust)) + (or (plist-get options (if buffer :scale :html-scale)) 1.0))) + (dpi (* scale (if buffer (org--get-display-dpi) 140.0))) (fg (or (plist-get options (if buffer :foreground :html-foreground)) "Black")) (bg (or (plist-get options (if buffer :background :html-background)) - "Transparent"))) - (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)))) - (let ((latex-header (org-create-formula--latex-header))) + "Transparent")) + (log-buf (get-buffer-create "*Org Preview LaTeX Output*")) + (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"))) - (let ((dir default-directory)) - (condition-case nil - (progn - (cd tmpdir) - (call-process "latex" nil nil nil texfile)) - (error nil)) - (cd dir)) - (if (not (file-exists-p dvifile)) - (progn (message "Failed to create dvi file from %s" texfile) nil) - (condition-case nil - (if (featurep 'xemacs) - (call-process "dvipng" nil nil nil - "-fg" fg "-bg" bg - "-T" "tight" - "-o" pngfile - dvifile) - (call-process "dvipng" nil nil nil - "-fg" fg "-bg" bg - "-D" dpi - ;;"-x" scale "-y" scale - "-T" "tight" - "-o" pngfile - dvifile)) - (error nil)) - (if (not (file-exists-p pngfile)) - (if org-format-latex-signal-error - (error "Failed to create png file from %s" texfile) - (message "Failed to create png file from %s" texfile) - nil) - ;; Use the requested file name and clean up - (copy-file pngfile tofile 'replace) - (loop for e in '(".dvi" ".tex" ".aux" ".log" ".png" ".out") do - (if (file-exists-p (concat texfilebase e)) - (delete-file (concat texfilebase e)))) - pngfile)))) - -(declare-function org-latex-compile "ox-latex" (texfile &optional snippet)) -(defun org-create-formula-image-with-imagemagick (string tofile options buffer) - "This calls convert, which is included into imagemagick." - (require 'ox-latex) - (let* ((tmpdir (if (featurep 'xemacs) - (temp-directory) - temporary-file-directory)) - (texfilebase (make-temp-name - (expand-file-name "orgtex" tmpdir))) - (texfile (concat texfilebase ".tex")) - (pdffile (concat texfilebase ".pdf")) - (pngfile (concat texfilebase ".png")) - (fnh (if (featurep 'xemacs) - (font-height (face-font 'default)) - (face-attribute 'default :height nil))) - (scale (or (plist-get options (if buffer :scale :html-scale)) 1.0)) - (dpi (number-to-string (* scale (floor (if buffer fnh 120.))))) - (fg (or (plist-get options (if buffer :foreground :html-foreground)) - "black")) - (bg (or (plist-get options (if buffer :background :html-background)) - "white"))) - (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)))) - (let ((latex-header (org-create-formula--latex-header))) - (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"))) - (org-latex-compile texfile t) - (if (not (file-exists-p pdffile)) - (progn (message "Failed to create pdf file from %s" texfile) nil) - (condition-case nil - (if (featurep 'xemacs) - (call-process "convert" nil nil nil - "-density" "96" - "-trim" - "-antialias" - pdffile - "-quality" "100" - ;; "-sharpen" "0x1.0" - pngfile) - (call-process "convert" nil nil nil - "-density" dpi - "-trim" - "-antialias" - pdffile - "-quality" "100" - ;; "-sharpen" "0x1.0" - pngfile)) - (error nil)) - (if (not (file-exists-p pngfile)) - (if org-format-latex-signal-error - (error "Failed to create png file from %s" texfile) - (message "Failed to create png file from %s" texfile) - nil) - ;; Use the requested file name and clean up - (copy-file pngfile tofile 'replace) - (loop for e in '(".pdf" ".tex" ".aux" ".log" ".png") do - (if (file-exists-p (concat texfilebase e)) - (delete-file (concat texfilebase e)))) - pngfile)))) + + (let* ((err-msg (format "Please adjust '%s' part of \ +`org-preview-latex-process-alist'." + processing-type)) + (image-input-file + (org-compile-file + texfile latex-compiler image-input-type err-msg log-buf)) + (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))) + (?S . ,(shell-quote-argument (format "%s" (/ dpi 140.0)))))))) + (copy-file image-output-file tofile 'replace) + (dolist (e post-clean) + (when (file-exists-p (concat texfilebase e)) + (delete-file (concat texfilebase e)))) + image-output-file))) (defun org-splice-latex-header (tpl def-pkg pkg snippets-p &optional extra) "Fill a LaTeX header template TPL. @@ -18830,22 +19507,22 @@ SNIPPETS-P indicates if this is run to create snippet images for HTML." (setq rpl (if (or (match-end 1) (not def-pkg)) "" (org-latex-packages-to-string def-pkg snippets-p t)) tpl (replace-match rpl t t tpl)) - (if def-pkg (setq end (org-latex-packages-to-string def-pkg snippets-p)))) + (when def-pkg (setq end (org-latex-packages-to-string def-pkg snippets-p)))) (if (string-match "\\[\\(NO-\\)?PACKAGES\\][ \t]*\n?" tpl) (setq rpl (if (or (match-end 1) (not pkg)) "" (org-latex-packages-to-string pkg snippets-p t)) tpl (replace-match rpl t t tpl)) - (if pkg (setq end - (concat end "\n" - (org-latex-packages-to-string pkg snippets-p))))) + (when pkg (setq end + (concat end "\n" + (org-latex-packages-to-string pkg snippets-p))))) (if (string-match "\\[\\(NO-\\)?EXTRA\\][ \t]*\n?" tpl) (setq rpl (if (or (match-end 1) (not extra)) "" (concat extra "\n")) tpl (replace-match rpl t t tpl)) - (if (and extra (string-match "\\S-" extra)) - (setq end (concat end "\n" extra)))) + (when (and extra (string-match "\\S-" extra)) + (setq end (concat end "\n" extra)))) (if (string-match "\\S-" end) (concat tpl "\n" end) @@ -18869,35 +19546,21 @@ SNIPPETS-P indicates if this is run to create snippet images for HTML." (defun org-dvipng-color (attr) "Return a RGB color specification for dvipng." - (apply 'format "rgb %s %s %s" - (mapcar 'org-normalize-color - (if (featurep 'xemacs) - (color-rgb-components - (face-property 'default - (cond ((eq attr :foreground) 'foreground) - ((eq attr :background) 'background)))) - (color-values (face-attribute 'default attr nil)))))) + (org-dvipng-color-format (face-attribute 'default attr nil))) (defun org-dvipng-color-format (color-name) "Convert COLOR-NAME to a RGB color value for dvipng." - (apply 'format "rgb %s %s %s" + (apply #'format "rgb %s %s %s" (mapcar 'org-normalize-color - (color-values color-name)))) + (color-values color-name)))) (defun org-latex-color (attr) "Return a RGB color for the LaTeX color package." - (apply 'format "%s,%s,%s" - (mapcar 'org-normalize-color - (if (featurep 'xemacs) - (color-rgb-components - (face-property 'default - (cond ((eq attr :foreground) 'foreground) - ((eq attr :background) 'background)))) - (color-values (face-attribute 'default attr nil)))))) + (org-latex-color-format (face-attribute 'default attr nil))) (defun org-latex-color-format (color-name) "Convert COLOR-NAME to a RGB color value." - (apply 'format "%s,%s,%s" + (apply #'format "%s,%s,%s" (mapcar 'org-normalize-color (color-values color-name)))) @@ -18909,8 +19572,7 @@ SNIPPETS-P indicates if this is run to create snippet images for HTML." ;; Image display -(defvar org-inline-image-overlays nil) -(make-variable-buffer-local 'org-inline-image-overlays) +(defvar-local org-inline-image-overlays nil) (defun org-toggle-inline-images (&optional include-linked) "Toggle the display of inline images. @@ -18919,13 +19581,14 @@ INCLUDE-LINKED is passed to `org-display-inline-images'." (if org-inline-image-overlays (progn (org-remove-inline-images) - (message "Inline image display turned off")) + (when (called-interactively-p 'interactive) + (message "Inline image display turned off"))) (org-display-inline-images include-linked) - (if (and (org-called-interactively-p) - org-inline-image-overlays) - (message "%d images displayed inline" - (length org-inline-image-overlays)) - (message "No images to display inline")))) + (when (called-interactively-p 'interactive) + (message (if org-inline-image-overlays + (format "%d images displayed inline" + (length org-inline-image-overlays)) + "No images to display inline"))))) (defun org-redisplay-inline-images () "Refresh the display of inline images." @@ -18937,68 +19600,116 @@ INCLUDE-LINKED is passed to `org-display-inline-images'." (defun org-display-inline-images (&optional include-linked refresh beg end) "Display inline images. -Normally only links without a description part are inlined, because this -is how it will work for export. When INCLUDE-LINKED is set, also links -with a description part will be inlined. This can be nice for a quick -look at those images, but it does not reflect what exported files will look -like. -When REFRESH is set, refresh existing images between BEG and END. -This will create new image displays only if necessary. -BEG and END default to the buffer boundaries." + +An inline image is a link which follows either of these +conventions: + + 1. Its path is a file with an extension matching return value + from `image-file-name-regexp' and it has no contents. + + 2. Its description consists in a single link of the previous + type. + +When optional argument INCLUDE-LINKED is non-nil, also links with +a text description part will be inlined. This can be nice for +a quick look at those images, but it does not reflect what +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." (interactive "P") (when (display-graphic-p) (unless refresh (org-remove-inline-images) - (if (fboundp 'clear-image-cache) (clear-image-cache))) - (save-excursion - (save-restriction - (widen) - (setq beg (or beg (point-min)) end (or end (point-max))) - (goto-char beg) - (let ((re (concat "\\[\\[\\(\\(file:\\)\\|\\([./~]\\)\\)\\([^]\n]+?" - (substring (org-image-file-name-regexp) 0 -2) - "\\)\\]" (if include-linked "" "\\]"))) - (case-fold-search t) - old file ov img type attrwidth width) - (while (re-search-forward re end t) - (setq old (get-char-property-and-overlay (match-beginning 1) - 'org-image-overlay) - file (expand-file-name - (concat (or (match-string 3) "") (match-string 4)))) - (when (image-type-available-p 'imagemagick) - (setq attrwidth (if (or (listp org-image-actual-width) - (null org-image-actual-width)) - (save-excursion - (save-match-data - (when (re-search-backward - "#\\+attr.*:width[ \t]+\\([^ ]+\\)" - (save-excursion - (re-search-backward "^[ \t]*$\\|\\`" nil t)) t) - (string-to-number (match-string 1)))))) - width (cond ((eq org-image-actual-width t) nil) - ((null org-image-actual-width) attrwidth) - ((numberp org-image-actual-width) - org-image-actual-width) - ((listp org-image-actual-width) - (or attrwidth (car org-image-actual-width)))) - type (if width 'imagemagick))) - (when (file-exists-p file) - (if (and (car-safe old) refresh) - (image-refresh (overlay-get (cdr old) 'display)) - (setq img (save-match-data (create-image file type nil :width width))) - (when img - (setq ov (make-overlay (match-beginning 0) (match-end 0))) - (overlay-put ov 'display img) - (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)))))))))) - -(define-obsolete-function-alias - 'org-display-inline-modification-hook 'org-display-inline-remove-overlay "24.3") - -(defun org-display-inline-remove-overlay (ov after beg end &optional len) + (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))) + (while (re-search-forward "[][]\\[\\(?:file\\|[./~]\\)" end t) + (let ((link (save-match-data (org-element-context)))) + ;; Check if we're at an inline image. + (when (and (equal (org-element-property :type link) "file") + (or include-linked + (not (org-element-property :contents-begin link))) + (let ((parent (org-element-property :parent link))) + (or (not (eq (org-element-type parent) 'link)) + (not (cdr (org-element-contents parent))))) + (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* ((link + ;; If inline image is the description + ;; of another link, be sure to + ;; consider the latter as the one to + ;; apply the overlay on. + (let ((parent + (org-element-property :parent link))) + (if (eq (org-element-type parent) 'link) + parent + link))) + (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))))))))))))))) + +(defun org-display-inline-remove-overlay (ov after _beg _end &optional _len) "Remove inline-display overlay if a corresponding region is modified." (let ((inhibit-modification-hooks t)) (when (and ov after) @@ -19008,7 +19719,7 @@ BEG and END default to the buffer boundaries." (defun org-remove-inline-images () "Remove inline display of images." (interactive) - (mapc 'delete-overlay org-inline-image-overlays) + (mapc #'delete-overlay org-inline-image-overlays) (setq org-inline-image-overlays nil)) ;;;; Key bindings @@ -19016,44 +19727,46 @@ BEG and END default to the buffer boundaries." ;; 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 show-subtree] 'org-show-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 show-branches] +(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-next-visible-heading' | `C-c C-n' | still same function | -;; | `outline-previous-visible-heading' | `C-c C-p' | still same function | -;; | `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-children' | `C-c C-i' | visibility cycling | -;; | `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 | + +;; | 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)) @@ -19064,8 +19777,7 @@ BEG and END default to the buffer boundaries." (org-defkey org-mode-map [(control tab)] 'org-force-cycle-archived) (org-defkey org-mode-map "\M-\t" #'pcomplete) ;; The following line is necessary under Suse GNU/Linux -(unless (featurep 'xemacs) - (org-defkey org-mode-map [S-iso-lefttab] 'org-shifttab)) +(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) @@ -19079,6 +19791,8 @@ BEG and END default to the buffer boundaries." (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) @@ -19096,17 +19810,14 @@ BEG and END default to the buffer boundaries." ;; Babel keys (define-key org-mode-map org-babel-key-prefix org-babel-map) -(mapc (lambda (pair) - (define-key org-babel-map (car pair) (cdr pair))) - org-babel-key-bindings) +(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 - (featurep 'xemacs) ;; because XEmacs supports multi-device stuff - (not window-system)) +(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) @@ -19138,7 +19849,7 @@ BEG and END default to the buffer boundaries." ;; All the other keys -(org-defkey org-mode-map "\C-c\C-a" 'show-all) ; in case allout messed up. +(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) @@ -19185,6 +19896,7 @@ BEG and END default to the buffer boundaries." (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) @@ -19209,8 +19921,10 @@ BEG and END default to the buffer boundaries." (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) @@ -19219,6 +19933,8 @@ BEG and END default to the buffer boundaries." (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) @@ -19226,7 +19942,7 @@ BEG and END default to the buffer boundaries." (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-section) +(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) @@ -19250,7 +19966,7 @@ BEG and END default to the buffer boundaries." (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-preview-latex-fragment) +(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) @@ -19260,9 +19976,8 @@ BEG and END default to the buffer boundaries." (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-insert-columns-dblock) +(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 [(control ?c) (control ?x) ?\:] 'org-timer-cancel-timer) (org-defkey org-mode-map "\C-c\C-x." 'org-timer) (org-defkey org-mode-map "\C-c\C-x-" 'org-timer-item) @@ -19280,15 +19995,11 @@ BEG and END default to the buffer boundaries." (define-key org-mode-map "\C-c\C-x[" 'org-reftex-citation) -(when (featurep 'xemacs) - (org-defkey org-mode-map 'button3 'popup-mode-menu)) - - (defconst org-speed-commands-default '( ("Outline Navigation") - ("n" . (org-speed-move-safe 'outline-next-visible-heading)) - ("p" . (org-speed-move-safe 'outline-previous-visible-heading)) + ("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) @@ -19303,8 +20014,8 @@ BEG and END default to the buffer boundaries." ("s" . org-narrow-to-subtree) ("=" . org-columns) ("Outline Structure Editing") - ("U" . org-shiftmetaup) - ("D" . org-shiftmetadown) + ("U" . org-metaup) + ("D" . org-metadown) ("r" . org-metaright) ("l" . org-metaleft) ("R" . org-shiftmetaright) @@ -19364,10 +20075,10 @@ BEG and END default to the buffer boundaries." (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) + (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)) + (mapc #'org-print-speed-command org-speed-commands-default)) (with-current-buffer "*Help*" (setq truncate-lines t)))) @@ -19386,9 +20097,6 @@ If not, return to the original position and throw an error." (defvar org-table-auto-blank-field) ; defined in org-table.el (defvar org-speed-command nil) -(define-obsolete-function-alias - 'org-speed-command-default-hook 'org-speed-command-activate "24.3") - (defun org-speed-command-activate (keys) "Hook for activating single-letter speed commands. `org-speed-commands-default' specifies a minimal command set. @@ -19399,9 +20107,6 @@ Use `org-speed-commands-user' for further customization." (cdr (assoc keys (append org-speed-commands-user org-speed-commands-default))))) -(define-obsolete-function-alias - 'org-babel-speed-command-hook 'org-babel-speed-command-activate "24.3") - (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)) @@ -19434,9 +20139,11 @@ overwritten, and the table is not marked as requiring realignment." (org-check-before-invisible-edit 'insert) (cond ((and org-use-speed-commands - (setq org-speed-command - (run-hook-with-args-until-success - 'org-speed-command-hook (this-command-keys)))) + (let ((kv (this-command-keys-vector))) + (setq org-speed-command + (run-hook-with-args-until-success + 'org-speed-command-hook + (make-string 1 (aref kv (1- (length kv)))))))) (cond ((commandp org-speed-command) (setq this-command org-speed-command) @@ -19448,94 +20155,98 @@ overwritten, and the table is not marked as requiring realignment." (t (let (org-use-speed-commands) (call-interactively 'org-self-insert-command))))) ((and - (org-table-p) + (org-at-table-p) (progn - ;; check if we blank the field, and if that triggers align + ;; Check if we blank the field, and if that triggers align. (and (featurep 'org-table) org-table-auto-blank-field - (member last-command - '(org-cycle org-return org-shifttab org-ctrl-c-ctrl-c yas/expand)) - (if (or (equal (char-after) ?\ ) (looking-at "[^|\n]* |")) - ;; got extra space, this field does not determine column width + (memq last-command + '(org-cycle org-return org-shifttab org-ctrl-c-ctrl-c)) + (if (or (eq (char-after) ?\s) (looking-at "[^|\n]* |")) + ;; Got extra space, this field does not determine + ;; column width. (let (org-table-may-need-update) (org-table-blank-field)) - ;; no extra space, this field may determine column width + ;; No extra space, this field may determine column + ;; width. (org-table-blank-field))) t) (eq N 1) - (looking-at "[^|\n]* |")) - (let (org-table-may-need-update) - (goto-char (1- (match-end 0))) - (backward-delete-char 1) - (goto-char (match-beginning 0)) - (self-insert-command 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)) (t (setq org-table-may-need-update t) (self-insert-command N) (org-fix-tags-on-the-fly) - (if org-self-insert-cluster-for-undo - (if (not (eq last-command 'org-self-insert-command)) + (when org-self-insert-cluster-for-undo + (if (not (eq last-command 'org-self-insert-command)) + (setq org-self-insert-command-undo-counter 1) + (if (>= org-self-insert-command-undo-counter 20) (setq org-self-insert-command-undo-counter 1) - (if (>= org-self-insert-command-undo-counter 20) - (setq org-self-insert-command-undo-counter 1) - (and (> org-self-insert-command-undo-counter 0) - buffer-undo-list (listp buffer-undo-list) - (not (cadr buffer-undo-list)) ; remove nil entry - (setcdr buffer-undo-list (cddr buffer-undo-list))) - (setq org-self-insert-command-undo-counter - (1+ org-self-insert-command-undo-counter)))))))) + (and (> org-self-insert-command-undo-counter 0) + buffer-undo-list (listp buffer-undo-list) + (not (cadr buffer-undo-list)) ; remove nil entry + (setcdr buffer-undo-list (cddr buffer-undo-list))) + (setq org-self-insert-command-undo-counter + (1+ org-self-insert-command-undo-counter)))))))) (defun org-check-before-invisible-edit (kind) "Check is editing if kind KIND would be dangerous with invisible text around. The detailed reaction depends on the user option `org-catch-invisible-edits'." ;; First, try to get out of here as quickly as possible, to reduce overhead - (if (and org-catch-invisible-edits - (or (not (boundp 'visible-mode)) (not visible-mode)) - (or (get-char-property (point) 'invisible) - (get-char-property (max (point-min) (1- (point))) 'invisible))) - ;; OK, we need to take a closer look - (let* ((invisible-at-point (get-char-property (point) 'invisible)) - (invisible-before-point (if (bobp) nil (get-char-property - (1- (point)) 'invisible))) - (border-and-ok-direction - (or - ;; Check if we are acting predictably before invisible text - (and invisible-at-point (not invisible-before-point) - (memq kind '(insert delete-backward))) - ;; Check if we are acting predictably after invisible text - ;; This works not well, and I have turned it off. It seems - ;; better to always show and stop after invisible text. - ;; (and (not invisible-at-point) invisible-before-point - ;; (memq kind '(insert delete))) - ))) - (when (or (memq invisible-at-point '(outline org-hide-block t)) - (memq invisible-before-point '(outline org-hide-block t))) - (if (eq org-catch-invisible-edits 'error) - (user-error "Editing in invisible areas is prohibited, make them visible first")) - (if (and org-custom-properties-overlays - (y-or-n-p "Display invisible properties in this buffer? ")) - (org-toggle-custom-properties-visibility) - ;; Make the area visible - (save-excursion - (if invisible-before-point - (goto-char (previous-single-char-property-change - (point) 'invisible))) - (show-subtree)) - (cond - ((eq org-catch-invisible-edits 'show) - ;; That's it, we do the edit after showing - (message - "Unfolding invisible region around point before editing") - (sit-for 1)) - ((and (eq org-catch-invisible-edits 'smart) - border-and-ok-direction) - (message "Unfolding invisible region around point before editing")) - (t - ;; Don't do the edit, make the user repeat it in full visibility - (user-error "Edit in invisible region aborted, repeat to confirm with text visible")))))))) + (when (and org-catch-invisible-edits + (or (not (boundp 'visible-mode)) (not visible-mode)) + (or (get-char-property (point) 'invisible) + (get-char-property (max (point-min) (1- (point))) 'invisible))) + ;; OK, we need to take a closer look + (let* ((invisible-at-point (get-char-property (point) 'invisible)) + (invisible-before-point (unless (bobp) (get-char-property + (1- (point)) 'invisible))) + (border-and-ok-direction + (or + ;; Check if we are acting predictably before invisible text + (and invisible-at-point (not invisible-before-point) + (memq kind '(insert delete-backward))) + ;; Check if we are acting predictably after invisible text + ;; This works not well, and I have turned it off. It seems + ;; better to always show and stop after invisible text. + ;; (and (not invisible-at-point) invisible-before-point + ;; (memq kind '(insert delete))) + ))) + (when (or (memq invisible-at-point '(outline org-hide-block t)) + (memq invisible-before-point '(outline org-hide-block t))) + (when (eq org-catch-invisible-edits 'error) + (user-error "Editing in invisible areas is prohibited, make them visible first")) + (if (and org-custom-properties-overlays + (y-or-n-p "Display invisible properties in this buffer? ")) + (org-toggle-custom-properties-visibility) + ;; Make the area visible + (save-excursion + (when invisible-before-point + (goto-char (previous-single-char-property-change + (point) 'invisible))) + (outline-show-subtree)) + (cond + ((eq org-catch-invisible-edits 'show) + ;; That's it, we do the edit after showing + (message + "Unfolding invisible region around point before editing") + (sit-for 1)) + ((and (eq org-catch-invisible-edits 'smart) + border-and-ok-direction) + (message "Unfolding invisible region around point before editing")) + (t + ;; Don't do the edit, make the user repeat it in full visibility + (user-error "Edit in invisible region aborted, repeat to confirm with text visible")))))))) (defun org-fix-tags-on-the-fly () - (when (and (equal (char-after (point-at-bol)) ?*) + "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)) - (org-align-tags-here org-tags-column))) + (let ((org-ignore-region t) + (org-tags-sort-function nil)) + (org-set-tags nil t)))) (defun org-delete-backward-char (N) "Like `delete-backward-char', insert whitespace at field end in tables. @@ -19546,7 +20257,7 @@ 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-table-p) + (if (and (org-at-table-p) (eq N 1) (string-match "|" (buffer-substring (point-at-bol) (point))) (looking-at ".*?|")) @@ -19554,14 +20265,13 @@ because, in this case the deletion might narrow the column." (noalign (looking-at "[^|\n\r]* |")) (c org-table-may-need-update)) (backward-delete-char N) - (if (not overwrite-mode) - (progn - (skip-chars-forward "^|") - (insert " ") - (goto-char (1- pos)))) + (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. - (if noalign (setq org-table-may-need-update c))) + (when noalign (setq org-table-may-need-update c))) (backward-delete-char N) (org-fix-tags-on-the-fly)))) @@ -19574,7 +20284,7 @@ because, in this case the deletion might narrow the column." (interactive "p") (save-match-data (org-check-before-invisible-edit 'delete) - (if (and (org-table-p) + (if (and (org-at-table-p) (not (bolp)) (not (= (char-after) ?|)) (eq N 1)) @@ -19587,12 +20297,12 @@ because, in this case the deletion might narrow the column." (goto-char pos) ;; noalign: if there were two spaces at the end, this field ;; does not determine the width of the column. - (if noalign (setq org-table-may-need-update c))) + (when noalign (setq org-table-may-need-update c))) (delete-char N)) (delete-char N) (org-fix-tags-on-the-fly)))) -;; Make `delete-selection-mode' work with org-mode and orgtbl-mode +;; Make `delete-selection-mode' work with Org mode and Orgtbl mode (put 'org-self-insert-command 'delete-selection (lambda () (not (run-hook-with-args-until-success @@ -19611,7 +20321,7 @@ because, in this case the deletion might narrow the column." (put 'org-delete-char 'flyspell-delayed t) (put 'org-delete-backward-char 'flyspell-delayed t) -;; Make pabbrev-mode expand after org-mode commands +;; Make pabbrev-mode expand after Org mode commands (put 'org-self-insert-command 'pabbrev-expand-after-command t) (put 'orgtbl-self-insert-command 'pabbrev-expand-after-command t) @@ -19621,9 +20331,7 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names." (let (new old) (while commands (setq old (pop commands) new (pop commands)) - (if (fboundp 'command-remapping) - (org-defkey map (vector 'remap old) new) - (substitute-key-definition old new map global-map))))) + (org-defkey map (vector 'remap old) new)))) (defun org-transpose-words () "Transpose words for Org. @@ -19765,7 +20473,7 @@ See `org-ctrl-c-ctrl-c-hook' for more information.") (defun org-shiftselect-error () "Throw an error because Shift-Cursor command was applied in wrong context." (if (and (boundp 'shift-select-mode) shift-select-mode) - (user-error "To use shift-selection with Org-mode, customize `org-support-shift-select'") + (user-error "To use shift-selection with Org mode, customize `org-support-shift-select'") (user-error "This command works only in special context like headlines or timestamps"))) (defun org-call-for-shift-select (cmd) @@ -19820,32 +20528,30 @@ individual commands for more information." (call-interactively 'org-indent-item-tree)) (t (org-modifier-cursor-error)))) -(defun org-shiftmetaup (&optional arg) - "Move subtree up or kill table row. -Calls `org-move-subtree-up' or `org-table-kill-row' or -`org-move-item-up' or `org-timestamp-up', depending on context. -See the individual commands for more information." +(defun org-shiftmetaup (&optional _arg) + "Drag the line at point up. +In a table, kill the current row. +On a clock timestamp, update the value of the timestamp like `S-<up>' +but also adjust the previous clocked item in the clock history. +Everywhere else, drag the line at point up." (interactive "P") (cond ((run-hook-with-args-until-success 'org-shiftmetaup-hook)) ((org-at-table-p) (call-interactively 'org-table-kill-row)) - ((org-at-heading-p) (call-interactively 'org-move-subtree-up)) - ((org-at-item-p) (call-interactively 'org-move-item-up)) ((org-at-clock-log-p) (let ((org-clock-adjust-closest t)) (call-interactively 'org-timestamp-up))) (t (call-interactively 'org-drag-line-backward)))) -(defun org-shiftmetadown (&optional arg) - "Move subtree down or insert table row. -Calls `org-move-subtree-down' or `org-table-insert-row' or -`org-move-item-down' or `org-timestamp-up', depending on context. -See the individual commands for more information." +(defun org-shiftmetadown (&optional _arg) + "Drag the line at point down. +In a table, insert an empty row at the current line. +On a clock timestamp, update the value of the timestamp like `S-<down>' +but also adjust the previous clocked item in the clock history. +Everywhere else, drag the line at point down." (interactive "P") (cond ((run-hook-with-args-until-success 'org-shiftmetadown-hook)) ((org-at-table-p) (call-interactively 'org-table-insert-row)) - ((org-at-heading-p) (call-interactively 'org-move-subtree-down)) - ((org-at-item-p) (call-interactively 'org-move-item-down)) ((org-at-clock-log-p) (let ((org-clock-adjust-closest t)) (call-interactively 'org-timestamp-down))) (t (call-interactively 'org-drag-line-forward)))) @@ -19854,11 +20560,16 @@ See the individual commands for more information." (user-error "Hidden subtree, open with TAB or use subtree command M-S-<left>/<right>")) -(defun org-metaleft (&optional arg) - "Promote heading or move table column to left. -Calls `org-do-promote' or `org-table-move-column', depending on context. -With no specific context, calls the Emacs default `backward-word'. -See the individual commands for more information." +(defun org-metaleft (&optional _arg) + "Promote heading, list item at point or move table column left. + +Calls `org-do-promote', `org-outdent-item' or `org-table-move-column', +depending on context. With no specific context, calls the Emacs +default `backward-word'. See the individual commands for more +information. + +This function runs the hook `org-metaleft-hook' as a first step, +and returns at first non-nil value." (interactive "P") (cond ((run-hook-with-args-until-success 'org-metaleft-hook)) @@ -19883,11 +20594,18 @@ See the individual commands for more information." (call-interactively 'org-outdent-item)) (t (call-interactively 'backward-word)))) -(defun org-metaright (&optional arg) - "Demote a subtree, a list item or move table column to right. +(defun org-metaright (&optional _arg) + "Demote heading, list item at point or move table column right. + In front of a drawer or a block keyword, indent it correctly. + +Calls `org-do-demote', `org-indent-item', `org-table-move-column', +`org-indent-drawer' or `org-indent-block' depending on context. With no specific context, calls the Emacs default `forward-word'. -See the individual commands for more information." +See the individual commands for more information. + +This function runs the hook `org-metaright-hook' as a first step, +and returns at first non-nil value." (interactive "P") (cond ((run-hook-with-args-until-success 'org-metaright-hook)) @@ -19937,11 +20655,11 @@ this function returns t, nil otherwise." (goto-char (point-at-eol)) (setq end (max end (point))) (while (re-search-forward re end t) - (if (get-char-property (match-beginning 0) 'invisible) - (throw 'exit t)))) + (when (get-char-property (match-beginning 0) 'invisible) + (throw 'exit t)))) nil)))) -(defun org-metaup (&optional arg) +(defun org-metaup (&optional _arg) "Move subtree up or move table row up. Calls `org-move-subtree-up' or `org-table-move-row' or `org-move-item-up', depending on context. See the individual commands @@ -19963,7 +20681,7 @@ for more information." ((org-at-item-p) (call-interactively 'org-move-item-up)) (t (org-drag-element-backward)))) -(defun org-metadown (&optional arg) +(defun org-metadown (&optional _arg) "Move subtree down or move table row down. Calls `org-move-subtree-down' or `org-table-move-row' or `org-move-item-down', depending on context. See the individual @@ -20149,6 +20867,32 @@ Optional argument N tells to change by that many units." (org-clock-timestamps-down n)) (user-error "Not at a clock log"))) +(defun org-increase-number-at-point (&optional inc) + "Increment the number at point. +With an optional prefix numeric argument INC, increment using +this numeric value." + (interactive "p") + (if (not (number-at-point)) + (user-error "Not on a number") + (unless inc (setq inc 1)) + (let ((pos (point)) + (beg (skip-chars-backward "-+^/*0-9eE.")) + (end (skip-chars-forward "-+^/*0-9eE^.")) nap) + (setq nap (buffer-substring-no-properties + (+ pos beg) (+ pos beg end))) + (delete-region (+ pos beg) (+ pos beg end)) + (insert (calc-eval (concat (number-to-string inc) "+" nap)))) + (when (org-at-table-p) + (org-table-align) + (org-table-end-of-field 1)))) + +(defun org-decrease-number-at-point (&optional inc) + "Decrement the number at point. +With an optional prefix numeric argument INC, decrement using +this numeric value." + (interactive "p") + (org-increase-number-at-point (- (or inc 1)))) + (defun org-ctrl-c-ret () "Call `org-table-hline-and-move' or `org-insert-heading' dep. on context." (interactive) @@ -20183,19 +20927,19 @@ Optional argument N tells to change by that many units." (defun org-copy-special () "Copy region in table or copy current subtree. -Calls `org-table-copy' or `org-copy-subtree', depending on context. -See the individual commands for more information." +Calls `org-table-copy-region' or `org-copy-subtree', depending on +context. See the individual commands for more information." (interactive) (call-interactively - (if (org-at-table-p) 'org-table-copy-region 'org-copy-subtree))) + (if (org-at-table-p) #'org-table-copy-region #'org-copy-subtree))) (defun org-cut-special () "Cut region in table or cut current subtree. -Calls `org-table-copy' or `org-cut-subtree', depending on context. -See the individual commands for more information." +Calls `org-table-cut-region' or `org-cut-subtree', depending on +context. See the individual commands for more information." (interactive) (call-interactively - (if (org-at-table-p) 'org-table-cut-region 'org-cut-subtree))) + (if (org-at-table-p) #'org-table-cut-region #'org-cut-subtree))) (defun org-paste-special (arg) "Paste rectangular region into table, or past subtree relative to level. @@ -20206,57 +20950,65 @@ See the individual commands for more information." (org-table-paste-rectangle) (org-paste-subtree arg))) -(defsubst org-in-fixed-width-region-p () - "Is point in a fixed-width region?" - (save-match-data - (eq 'fixed-width (org-element-type (org-element-at-point))))) - (defun org-edit-special (&optional arg) "Call a special editor for the element at point. When at a table, call the formula editor with `org-table-edit-formulas'. When in a source code block, call `org-edit-src-code'. When in a fixed-width region, call `org-edit-fixed-width-region'. +When in an export block, call `org-edit-export-block'. When at an #+INCLUDE keyword, visit the included file. +When at a footnote reference, call `org-edit-footnote-reference' On a link, call `ffap' to visit the link at point. Otherwise, return a user error." (interactive "P") (let ((element (org-element-at-point))) - (assert (not buffer-read-only) nil - "Buffer is read-only: %s" (buffer-name)) - (case (org-element-type element) - (src-block + (barf-if-buffer-read-only) + (pcase (org-element-type element) + (`src-block (if (not arg) (org-edit-src-code) - (let* ((info (org-babel-get-src-block-info)) - (lang (nth 0 info)) - (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. - (switch-to-buffer + (let* ((info (org-babel-get-src-block-info)) + (lang (nth 0 info)) + (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. + (switch-to-buffer (funcall (intern (concat "org-babel-prep-session:" lang)) session params)))))) - (keyword + (`keyword (if (member (org-element-property :key element) '("INCLUDE" "SETUPFILE")) - (find-file - (org-remove-double-quotes - (car (org-split-string (org-element-property :value element))))) + (org-open-link-from-string + (format "[[%s]]" + (expand-file-name + (let ((value (org-element-property :value element))) + (cond ((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"))) - (table + (`table (if (eq (org-element-property :type element) 'table.el) - (org-edit-src-code) + (org-edit-table.el) (call-interactively 'org-table-edit-formulas))) ;; Only Org tables contain `table-row' type elements. - (table-row (call-interactively 'org-table-edit-formulas)) - ((example-block export-block) (org-edit-src-code)) - (fixed-width (org-edit-fixed-width-region)) - (otherwise - ;; No notable element at point. Though, we may be at a link, - ;; which is an object. Thus, scan deeper. - (if (eq (org-element-type (org-element-context element)) 'link) - (call-interactively 'ffap) - (user-error "No special environment to edit here")))))) + (`table-row (call-interactively 'org-table-edit-formulas)) + (`example-block (org-edit-src-code)) + (`export-block (org-edit-export-block)) + (`fixed-width (org-edit-fixed-width-region)) + (_ + ;; No notable element at point. Though, we may be at a link or + ;; a footnote reference, which are objects. Thus, scan deeper. + (let ((context (org-element-context element))) + (pcase (org-element-type context) + (`footnote-reference (org-edit-footnote-reference)) + (`inline-src-block (org-edit-inline-src-code)) + (`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) @@ -20305,240 +21057,314 @@ This command does many different things, depending on context: inhibited by setting `org-babel-no-eval-on-ctrl-c-ctrl-c'." (interactive "P") (cond - ((or (and (boundp 'org-clock-overlays) org-clock-overlays) - org-occur-highlights - org-latex-fragment-image-overlays) - (and (boundp 'org-clock-overlays) (org-clock-remove-overlays)) + ((or (bound-and-true-p org-clock-overlays) org-occur-highlights) + (when (boundp 'org-clock-overlays) (org-clock-remove-overlays)) (org-remove-occur-highlights) - (org-remove-latex-fragment-image-overlays) (message "Temporary highlights/overlays removed from current buffer")) - ((and (local-variable-p 'org-finish-function (current-buffer)) + ((and (local-variable-p 'org-finish-function) (fboundp org-finish-function)) (funcall org-finish-function)) + ((org-babel-hash-at-point)) ((run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-hook)) (t - (let* ((context (org-element-context)) (type (org-element-type context))) - ;; Test if point is within a blank line. - (if (save-excursion (beginning-of-line) (looking-at "[ \t]*$")) - (or (run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-final-hook) - (user-error "C-c C-c can do nothing useful at this location")) - (case type - ;; When at a link, act according to the parent instead. - (link (setq context (org-element-property :parent context)) - (setq type (org-element-type context))) - ;; Unsupported object types: refer to the first supported - ;; element or object containing it. - ((bold code entity export-snippet inline-babel-call inline-src-block - italic latex-fragment line-break macro strike-through subscript - superscript underline verbatim) - (while (and (setq context (org-element-property :parent context)) - (not (memq (setq type (org-element-type context)) - '(radio-target paragraph verse-block - table-cell))))))) - ;; For convenience: at the first line of a paragraph on the - ;; same line as an item, apply function on that item instead. - (when (eq type 'paragraph) - (let ((parent (org-element-property :parent context))) - (when (and (eq (org-element-type parent) 'item) - (= (point-at-bol) (org-element-property :begin parent))) - (setq context parent type 'item)))) - ;; Act according to type of element or object at point. - (case type - (clock (org-clock-update-time-maybe)) - (dynamic-block - (save-excursion - (goto-char (org-element-property :post-affiliated context)) - (org-update-dblock))) - (footnote-definition + (let* ((context + (org-element-lineage + (org-element-context) + ;; Limit to supported contexts. + '(babel-call clock dynamic-block footnote-definition + footnote-reference inline-babel-call inline-src-block + inlinetask item keyword node-property paragraph + plain-list property-drawer radio-target src-block + statistics-cookie table table-cell table-row + timestamp) + t)) + (type (org-element-type context))) + ;; For convenience: at the first line of a paragraph on the same + ;; line as an item, apply function on that item instead. + (when (eq type 'paragraph) + (let ((parent (org-element-property :parent context))) + (when (and (eq (org-element-type parent) 'item) + (= (line-beginning-position) + (org-element-property :begin parent))) + (setq context parent) + (setq type 'item)))) + ;; 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 block and then if it is at a blank line. + (pcase type + ((or `inline-src-block `src-block) + (unless org-babel-no-eval-on-ctrl-c-ctrl-c + (org-babel-eval-wipe-error-buffer) + (org-babel-execute-src-block + current-prefix-arg (org-babel-get-src-block-info nil context)))) + ((guard (org-match-line "[ \t]*$")) + (or (run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-final-hook) + (user-error + (substitute-command-keys + "`\\[org-ctrl-c-ctrl-c]' can do nothing useful here")))) + ((or `babel-call `inline-babel-call) + (let ((info (org-babel-lob-get-info context))) + (when info (org-babel-execute-src-block nil info)))) + (`clock (org-clock-update-time-maybe)) + (`dynamic-block + (save-excursion (goto-char (org-element-property :post-affiliated context)) - (call-interactively 'org-footnote-action)) - (footnote-reference (call-interactively 'org-footnote-action)) - ((headline inlinetask) - (save-excursion (goto-char (org-element-property :begin context)) - (call-interactively 'org-set-tags))) - (item - ;; At an item: a double C-u set checkbox to "[-]" - ;; unconditionally, whereas a single one will toggle its - ;; presence. Without a universal argument, if the item - ;; has a checkbox, toggle it. Otherwise repair the list. - (let* ((box (org-element-property :checkbox context)) - (struct (org-element-property :structure context)) - (old-struct (copy-tree struct)) - (parents (org-list-parents-alist struct)) - (prevs (org-list-prevs-alist struct)) - (orderedp (org-not-nil (org-entry-get nil "ORDERED")))) - (org-list-set-checkbox - (org-element-property :begin context) struct - (cond ((equal arg '(16)) "[-]") - ((and (not box) (equal arg '(4))) "[ ]") - ((or (not box) (equal arg '(4))) nil) - ((eq box 'on) "[ ]") - (t "[X]"))) - ;; Mimic `org-list-write-struct' but with grabbing - ;; a return value from `org-list-struct-fix-box'. - (org-list-struct-fix-ind struct parents 2) - (org-list-struct-fix-item-end struct) - (org-list-struct-fix-bul struct prevs) - (org-list-struct-fix-ind struct parents) - (let ((block-item - (org-list-struct-fix-box struct parents prevs orderedp))) - (if (and box (equal struct old-struct)) - (if (equal arg '(16)) - (message "Checkboxes already reset") - (user-error "Cannot toggle this checkbox: %s" - (if (eq box 'on) - "all subitems checked" - "unchecked subitems"))) - (org-list-struct-apply-struct struct old-struct) - (org-update-checkbox-count-maybe)) - (when block-item - (message "Checkboxes were removed due to empty box at line %d" - (org-current-line block-item)))))) - (keyword - (let ((org-inhibit-startup-visibility-stuff t) - (org-startup-align-all-tables nil)) - (when (boundp 'org-table-coordinate-overlays) - (mapc 'delete-overlay org-table-coordinate-overlays) - (setq org-table-coordinate-overlays nil)) - (org-save-outline-visibility 'use-markers (org-mode-restart))) - (message "Local setup has been refreshed")) - (plain-list - ;; At a plain list, with a double C-u argument, set - ;; checkboxes of each item to "[-]", whereas a single one - ;; will toggle their presence according to the state of the - ;; 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 - (goto-char begin) - (looking-at org-list-full-item-re) - (match-string-no-properties 3))) - (new-box (cond ((equal arg '(16)) "[-]") - ((equal arg '(4)) (unless first-box "[ ]")) - ((equal first-box "[X]") "[ ]") - (t "[X]")))) - (cond - (arg - (mapc (lambda (pos) (org-list-set-checkbox pos struct new-box)) - (org-list-get-all-items - begin struct (org-list-prevs-alist struct)))) - ((and first-box (eq (point) begin)) - ;; For convenience, when point is at bol on the first - ;; 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)))) - ((property-drawer node-property) - (call-interactively 'org-property-action)) - ((radio-target target) - (call-interactively 'org-update-radio-target-regexp)) - (statistics-cookie - (call-interactively 'org-update-statistics-cookies)) - ((table table-cell table-row) - ;; At a table, recalculate every field and align it. Also - ;; send the table if necessary. If the table has - ;; a `table.el' type, just give up. At a table row or - ;; cell, maybe recalculate line but always align table. - (if (eq (org-element-property :type context) 'table.el) - (message "%s" "Use C-c ' to edit table.el tables") - (let ((org-enable-table-editor t)) - (if (or (eq type 'table) - ;; Check if point is at a TBLFM line. - (and (eq type 'table-row) - (= (point) (org-element-property :end context)))) - (save-excursion - (if (org-at-TBLFM-p) - (progn (require 'org-table) - (org-table-calc-current-TBLFM)) - (goto-char (org-element-property :contents-begin context)) - (org-call-with-arg 'org-table-recalculate (or arg t)) - (orgtbl-send-table 'maybe))) - (org-table-maybe-eval-formula) - (cond (arg (call-interactively 'org-table-recalculate)) - ((org-table-maybe-recalculate-line)) - (t (org-table-align))))))) - (timestamp (org-timestamp-change 0 'day)) - (otherwise - (or (run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-final-hook) - (user-error - "C-c C-c can do nothing useful at this location"))))))))) + (org-update-dblock))) + (`footnote-definition + (goto-char (org-element-property :post-affiliated context)) + (call-interactively 'org-footnote-action)) + (`footnote-reference (call-interactively #'org-footnote-action)) + ((or `headline `inlinetask) + (save-excursion (goto-char (org-element-property :begin context)) + (call-interactively #'org-set-tags))) + (`item + ;; At an item: `C-u C-u' sets checkbox to "[-]" + ;; unconditionally, whereas `C-u' will toggle its presence. + ;; Without a universal argument, if the item has a checkbox, + ;; toggle it. Otherwise repair the list. + (let* ((box (org-element-property :checkbox context)) + (struct (org-element-property :structure context)) + (old-struct (copy-tree struct)) + (parents (org-list-parents-alist struct)) + (prevs (org-list-prevs-alist struct)) + (orderedp (org-not-nil (org-entry-get nil "ORDERED")))) + (org-list-set-checkbox + (org-element-property :begin context) struct + (cond ((equal arg '(16)) "[-]") + ((and (not box) (equal arg '(4))) "[ ]") + ((or (not box) (equal arg '(4))) nil) + ((eq box 'on) "[ ]") + (t "[X]"))) + ;; Mimic `org-list-write-struct' but with grabbing a return + ;; value from `org-list-struct-fix-box'. + (org-list-struct-fix-ind struct parents 2) + (org-list-struct-fix-item-end struct) + (org-list-struct-fix-bul struct prevs) + (org-list-struct-fix-ind struct parents) + (let ((block-item + (org-list-struct-fix-box struct parents prevs orderedp))) + (if (and box (equal struct old-struct)) + (if (equal arg '(16)) + (message "Checkboxes already reset") + (user-error "Cannot toggle this checkbox: %s" + (if (eq box 'on) + "all subitems checked" + "unchecked subitems"))) + (org-list-struct-apply-struct struct old-struct) + (org-update-checkbox-count-maybe)) + (when block-item + (message "Checkboxes were removed due to empty box at line %d" + (org-current-line block-item)))))) + (`keyword + (let ((org-inhibit-startup-visibility-stuff t) + (org-startup-align-all-tables nil)) + (when (boundp 'org-table-coordinate-overlays) + (mapc #'delete-overlay org-table-coordinate-overlays) + (setq org-table-coordinate-overlays nil)) + (org-save-outline-visibility 'use-markers (org-mode-restart))) + (message "Local setup has been refreshed")) + (`plain-list + ;; At a plain list, with a double C-u argument, set + ;; checkboxes of each item to "[-]", whereas a single one + ;; will toggle their presence according to the state of the + ;; 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 + (goto-char begin) + (looking-at org-list-full-item-re) + (match-string-no-properties 3))) + (new-box (cond ((equal arg '(16)) "[-]") + ((equal arg '(4)) (unless first-box "[ ]")) + ((equal first-box "[X]") "[ ]") + (t "[X]")))) + (cond + (arg + (dolist (pos + (org-list-get-all-items + begin struct (org-list-prevs-alist struct))) + (org-list-set-checkbox pos struct new-box))) + ((and first-box (eq (point) begin)) + ;; For convenience, when point is at bol on the first + ;; 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)))) + ((or `property-drawer `node-property) + (call-interactively #'org-property-action)) + (`radio-target + (call-interactively #'org-update-radio-target-regexp)) + (`statistics-cookie + (call-interactively #'org-update-statistics-cookies)) + ((or `table `table-cell `table-row) + ;; At a table, recalculate every field and align it. Also + ;; send the table if necessary. If the table has + ;; a `table.el' type, just give up. At a table row or cell, + ;; maybe recalculate line but always align table. + (if (eq (org-element-property :type context) 'table.el) + (message "%s" (substitute-command-keys "\\<org-mode-map>\ +Use `\\[org-edit-special]' to edit table.el tables")) + (let ((org-enable-table-editor t)) + (if (or (eq type 'table) + ;; Check if point is at a TBLFM line. + (and (eq type 'table-row) + (= (point) (org-element-property :end context)))) + (save-excursion + (if (org-at-TBLFM-p) + (progn (require 'org-table) + (org-table-calc-current-TBLFM)) + (goto-char (org-element-property :contents-begin context)) + (org-call-with-arg 'org-table-recalculate (or arg t)) + (orgtbl-send-table 'maybe))) + (org-table-maybe-eval-formula) + (cond (arg (call-interactively #'org-table-recalculate)) + ((org-table-maybe-recalculate-line)) + (t (org-table-align))))))) + (`timestamp (org-timestamp-change 0 'day)) + ((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)) + ((guard + (run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-final-hook))) + (_ + (user-error + (substitute-command-keys + "`\\[org-ctrl-c-ctrl-c]' can do nothing useful here")))))))) (defun org-mode-restart () (interactive) - (let ((indent-status (org-bound-and-true-p org-indent-mode))) + (let ((indent-status (bound-and-true-p org-indent-mode))) (funcall major-mode) (hack-local-variables) - (when (and indent-status (not (org-bound-and-true-p org-indent-mode))) + (when (and indent-status (not (bound-and-true-p org-indent-mode))) (org-indent-mode -1))) (message "%s restarted" major-mode)) (defun org-kill-note-or-show-branches () - "If this is a Note buffer, abort storing the note. Else call `show-branches'." + "Abort storing current note, or call `outline-show-branches'." (interactive) (if (not org-finish-function) (progn - (hide-subtree) - (call-interactively 'show-branches)) + (outline-hide-subtree) + (call-interactively 'outline-show-branches)) (let ((org-note-abort t)) (funcall org-finish-function)))) +(defun org-delete-indentation (&optional arg) + "Join current line to previous and fix whitespace at join. + +If previous line is a headline add to headline title. Otherwise +the function calls `delete-indentation'. + +With a non-nil optional argument, join it to the following one." + (interactive "*P") + (if (save-excursion + (beginning-of-line (if arg 1 0)) + (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp))) + ;; At headline. + (let ((tags-column (when (match-beginning 5) + (save-excursion (goto-char (match-beginning 5)) + (current-column)))) + (string (concat " " (progn (when arg (forward-line 1)) + (org-trim (delete-and-extract-region + (line-beginning-position) + (line-end-position))))))) + (unless (bobp) (delete-region (point) (1- (point)))) + (goto-char (or (match-end 4) + (match-beginning 5) + (match-end 0))) + (skip-chars-backward " \t") + (save-excursion (insert string)) + ;; Adjust alignment of tags. + (cond + ((not tags-column)) ;no tags + (org-auto-align-tags (org-set-tags nil t)) + (t (org--align-tags-here tags-column)))) ;preserve tags column + (delete-indentation arg))) + (defun org-open-line (n) "Insert a new row in tables, call `open-line' elsewhere. -If `org-special-ctrl-o' is nil, just call `open-line' everywhere." +If `org-special-ctrl-o' is nil, just call `open-line' everywhere. +As a special case, when a document starts with a table, allow to +call `open-line' on the very first character." (interactive "*p") - (cond - ((not org-special-ctrl-o) - (open-line n)) - ((org-at-table-p) - (org-table-insert-row)) - (t - (open-line n)))) + (if (and org-special-ctrl-o (/= (point) 1) (org-at-table-p)) + (org-table-insert-row) + (open-line n))) (defun org-return (&optional indent) "Goto next table row or insert a newline. + Calls `org-table-next-row' or `newline', depending on context. -See the individual commands for more information." + +When optional INDENT argument is non-nil, call +`newline-and-indent' instead of `newline'. + +When `org-return-follows-link' is non-nil and point is on +a timestamp or a link, call `org-open-at-point'. However, it +will not happen if point is in a table or on a \"dead\" +object (e.g., within a comment). In these case, you need to use +`org-open-at-point' directly." (interactive) - (let (org-ts-what) + (let ((context (if org-return-follows-link (org-element-context) + (org-element-at-point)))) (cond - ((or (bobp) (org-in-src-block-p)) - (if indent (newline-and-indent) (newline))) - ((org-at-table-p) + ;; In a table, call `org-table-next-row'. + ((or (and (eq (org-element-type context) 'table) + (>= (point) (org-element-property :contents-begin context)) + (< (point) (org-element-property :contents-end context))) + (org-element-lineage context '(table-row table-cell) t)) (org-table-justify-field-maybe) - (call-interactively 'org-table-next-row)) - ;; when `newline-and-indent' is called within a list, make sure - ;; text moved stays inside the item. - ((and (org-in-item-p) indent) - (if (and (org-at-item-p) (>= (point) (match-end 0))) - (progn - (save-match-data (newline)) - (org-indent-line-to (length (match-string 0)))) - (let ((ind (org-get-indentation))) - (newline) - (if (org-looking-back org-list-end-re) - (org-indent-line) - (org-indent-line-to ind))))) - ((and org-return-follows-link - (org-at-timestamp-p t) - (not (eq org-ts-what 'after))) - (org-follow-timestamp-link)) + (call-interactively #'org-table-next-row)) + ;; On a link or a timestamp, call `org-open-at-point' if + ;; `org-return-follows-link' allows it. Tolerate fuzzy + ;; locations, e.g., in a comment, as `org-open-at-point'. ((and org-return-follows-link - (let ((tprop (get-text-property (point) 'face))) - (or (eq tprop 'org-link) - (and (listp tprop) (memq 'org-link tprop))))) - (call-interactively 'org-open-at-point)) - ((and (org-at-heading-p) - (looking-at - (org-re "\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)[ \t]*$"))) - (org-show-entry) - (end-of-line 1) - (newline)) + (or (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))) + (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)))) + ;; 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. + (let ((tags-column (and (match-beginning 5) + (save-excursion (goto-char (match-beginning 5)) + (current-column)))) + (string + (when (and (match-end 4) (org-point-in-group (point) 4)) + (delete-and-extract-region (point) (match-end 4))))) + ;; Adjust tag alignment. + (cond + ((not (and tags-column string))) + (org-auto-align-tags (org-set-tags nil t)) + (t (org--align-tags-here tags-column))) ;preserve tags column + (end-of-line) + (org-show-entry) + (if indent (newline-and-indent) (newline)) + (when string (save-excursion (insert (org-trim string)))))) + ;; In a list, make sure indenting keeps trailing text within. + ((and indent + (not (eolp)) + (org-element-lineage context '(item))) + (let ((trailing-data + (delete-and-extract-region (point) (line-end-position)))) + (newline-and-indent) + (save-excursion (insert trailing-data)))) (t (if indent (newline-and-indent) (newline)))))) (defun org-return-indent () @@ -20576,141 +21402,11 @@ Calls `org-table-insert-hline', `org-toggle-item', or (t (call-interactively 'org-toggle-item)))) -(defun org-toggle-item (arg) - "Convert headings or normal lines to items, items to normal lines. -If there is no active region, only the current line is considered. - -If the first non blank line in the region is a headline, convert -all headlines to items, shifting text accordingly. - -If it is an item, convert all items to normal lines. - -If it is normal text, change region into a list of items. -With a prefix argument ARG, change the region in a single item." - (interactive "P") - (let ((shift-text - (function - ;; Shift text in current section to IND, from point to END. - ;; The function leaves point to END line. - (lambda (ind end) - (let ((min-i 1000) (end (copy-marker end))) - ;; First determine the minimum indentation (MIN-I) of - ;; the text. - (save-excursion - (catch 'exit - (while (< (point) end) - (let ((i (org-get-indentation))) - (cond - ;; Skip blank lines and inline tasks. - ((looking-at "^[ \t]*$")) - ((looking-at org-outline-regexp-bol)) - ;; We can't find less than 0 indentation. - ((zerop i) (throw 'exit (setq min-i 0))) - ((< i min-i) (setq min-i i)))) - (forward-line)))) - ;; Then indent each line so that a line indented to - ;; MIN-I becomes indented to IND. Ignore blank lines - ;; and inline tasks in the process. - (let ((delta (- ind min-i))) - (while (< (point) end) - (unless (or (looking-at "^[ \t]*$") - (looking-at org-outline-regexp-bol)) - (org-indent-line-to (+ (org-get-indentation) delta))) - (forward-line))))))) - (skip-blanks - (function - ;; Return beginning of first non-blank line, starting from - ;; line at POS. - (lambda (pos) - (save-excursion - (goto-char pos) - (skip-chars-forward " \r\t\n") - (point-at-bol))))) - beg end) - ;; Determine boundaries of changes. - (if (org-region-active-p) - (setq beg (funcall skip-blanks (region-beginning)) - end (copy-marker (region-end))) - (setq beg (funcall skip-blanks (point-at-bol)) - end (copy-marker (point-at-eol)))) - ;; Depending on the starting line, choose an action on the text - ;; between BEG and END. - (org-with-limited-levels - (save-excursion - (goto-char beg) - (cond - ;; Case 1. Start at an item: de-itemize. Note that it only - ;; happens when a region is active: `org-ctrl-c-minus' - ;; would call `org-cycle-list-bullet' otherwise. - ((org-at-item-p) - (while (< (point) end) - (when (org-at-item-p) - (skip-chars-forward " \t") - (delete-region (point) (match-end 0))) - (forward-line))) - ;; Case 2. Start at an heading: convert to items. - ((org-at-heading-p) - (let* ((bul (org-list-bullet-string "-")) - (bul-len (length bul)) - ;; Indentation of the first heading. It should be - ;; relative to the indentation of its parent, if any. - (start-ind (save-excursion - (cond - ((not org-adapt-indentation) 0) - ((not (outline-previous-heading)) 0) - (t (length (match-string 0)))))) - ;; Level of first heading. Further headings will be - ;; compared to it to determine hierarchy in the list. - (ref-level (org-reduced-level (org-outline-level)))) - (while (< (point) end) - (let* ((level (org-reduced-level (org-outline-level))) - (delta (max 0 (- level ref-level)))) - ;; If current headline is less indented than the first - ;; one, set it as reference, in order to preserve - ;; subtrees. - (when (< level ref-level) (setq ref-level level)) - (replace-match bul t t) - (org-indent-line-to (+ start-ind (* delta bul-len))) - ;; Ensure all text down to END (or SECTION-END) belongs - ;; to the newly created item. - (let ((section-end (save-excursion - (or (outline-next-heading) (point))))) - (forward-line) - (funcall shift-text - (+ start-ind (* (1+ delta) bul-len)) - (min end section-end))))))) - ;; Case 3. Normal line with ARG: make the first line of region - ;; an item, and shift indentation of others lines to - ;; set them as item's body. - (arg (let* ((bul (org-list-bullet-string "-")) - (bul-len (length bul)) - (ref-ind (org-get-indentation))) - (skip-chars-forward " \t") - (insert bul) - (forward-line) - (while (< (point) end) - ;; Ensure that lines less indented than first one - ;; still get included in item body. - (funcall shift-text - (+ ref-ind bul-len) - (min end (save-excursion (or (outline-next-heading) - (point))))) - (forward-line)))) - ;; Case 4. Normal line without ARG: turn each non-item line - ;; into an item. - (t - (while (< (point) end) - (unless (or (org-at-heading-p) (org-at-item-p)) - (if (looking-at "\\([ \t]*\\)\\(\\S-\\)") - (replace-match - (concat "\\1" (org-list-bullet-string "-") "\\2")))) - (forward-line)))))))) - (defun org-toggle-heading (&optional nstars) "Convert headings to normal text, or items or text to headings. If there is no active region, only convert the current line. -With a \\[universal-argument] prefix, convert the whole list at +With a `\\[universal-argument]' prefix, convert the whole list at point into heading. In a region: @@ -20746,7 +21442,7 @@ number of stars to add." ;; do not consider the last line to be in the region. (when (and current-prefix-arg (org-at-item-p)) - (if (listp current-prefix-arg) (setq current-prefix-arg 1)) + (when (listp current-prefix-arg) (setq current-prefix-arg 1)) (org-mark-element)) (if (org-region-active-p) @@ -20771,31 +21467,17 @@ number of stars to add." ;; Case 2. Started at an item: change items into headlines. ;; One star will be added by `org-list-to-subtree'. ((org-at-item-p) - (let* ((stars (make-string - ;; subtract the star that will be added again by - ;; `org-list-to-subtree' - (if (numberp nstars) (1- nstars) - (or (org-current-level) 0)) - ?*)) - (add-stars - (cond (nstars "") ; stars from prefix only - ((equal stars "") "") ; before first heading - (org-odd-levels-only "*") ; inside heading, odd - (t "")))) ; inside heading, oddeven - (while (< (point) end) - (when (org-at-item-p) - ;; Pay attention to cases when region ends before list. - (let* ((struct (org-list-struct)) - (list-end (min (org-list-get-bottom-point struct) (1+ end)))) - (save-restriction - (narrow-to-region (point) list-end) - (insert - (org-list-to-subtree - (org-list-parse-list t) - `(:istart (concat ',stars ',add-stars (funcall get-stars depth)) - :icount (concat ',stars ',add-stars (funcall get-stars depth))))))) - (setq toggled t)) - (forward-line)))) + (while (< (point) end) + (when (org-at-item-p) + ;; Pay attention to cases when region ends before list. + (let* ((struct (org-list-struct)) + (list-end + (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"))) + (setq toggled t)) + (forward-line))) ;; Case 3. Started at normal text: make every line an heading, ;; skipping headlines and items. (t (let* ((stars @@ -20807,7 +21489,7 @@ number of stars to add." (org-odd-levels-only "**") ; inside heading, odd (t "*"))) ; inside heading, oddeven (rpl (concat stars add-stars " ")) - (lend (if (listp nstars) (save-excursion (end-of-line) (point))))) + (lend (when (listp nstars) (save-excursion (end-of-line) (point))))) (while (< (point) (if (equal nstars '(4)) lend end)) (when (and (not (or (org-at-heading-p) (org-at-item-p) (org-at-comment-p))) (looking-at "\\([ \t]*\\)\\(\\S-\\)")) @@ -20822,17 +21504,8 @@ on context. See the individual commands for more information." (interactive) (org-check-before-invisible-edit 'insert) (or (run-hook-with-args-until-success 'org-metareturn-hook) - (let* ((element (org-element-at-point)) - (type (org-element-type element))) - (when (eq type 'table-row) - (setq element (org-element-property :parent element)) - (setq type 'table)) - (if (and (eq type 'table) - (eq (org-element-property :type element) 'org) - (>= (point) (org-element-property :contents-begin element)) - (< (point) (org-element-property :contents-end element))) - (call-interactively 'org-table-wrap-region) - (call-interactively 'org-insert-heading))))) + (call-interactively (if (org-at-table-p) #'org-table-wrap-region + #'org-insert-heading)))) ;;; Menu entries @@ -20841,7 +21514,7 @@ on context. See the individual commands for more information." (and (not (org-before-first-heading-p)) (not (org-at-table-p)))) -;; Define the Org-mode menus +;; Define the Org mode menus (easy-menu-define org-tbl-menu org-mode-map "Tbl menu" '("Tbl" ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p)] @@ -20888,11 +21561,11 @@ on context. See the individual commands for more information." ["Which Column?" org-table-current-column (org-at-table-p)]) ["Debug Formulas" org-table-toggle-formula-debugger - :style toggle :selected (org-bound-and-true-p org-table-formula-debug)] + :style toggle :selected (bound-and-true-p org-table-formula-debug)] ["Show Col/Row Numbers" org-table-toggle-coordinate-overlays :style toggle - :selected (org-bound-and-true-p org-table-overlay-coordinates)] + :selected (bound-and-true-p org-table-overlay-coordinates)] "--" ["Create" org-table-create (and (not (org-at-table-p)) org-enable-table-editor)] @@ -20900,7 +21573,11 @@ on context. See the individual commands for more information." ["Import from File" org-table-import (not (org-at-table-p))] ["Export to File" org-table-export (org-at-table-p)] "--" - ["Create/Convert from/to table.el" org-table-create-with-table.el t])) + ["Create/Convert from/to table.el" org-table-create-with-table.el t] + "--" + ("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"]))) (easy-menu-define org-org-menu org-mode-map "Org menu" '("Org" @@ -20909,7 +21586,7 @@ on context. See the individual commands for more information." ["Cycle Global Visibility" org-shifttab :active (not (org-at-table-p))] ["Sparse Tree..." org-sparse-tree t] ["Reveal Context" org-reveal t] - ["Show All" show-all t] + ["Show All" outline-show-all t] "--" ["Subtree to indirect buffer" org-tree-to-indirect-buffer t]) "--" @@ -20925,8 +21602,8 @@ on context. See the individual commands for more information." ("Edit Structure" ["Refile Subtree" org-refile (org-in-subtree-not-table-p)] "--" - ["Move Subtree Up" org-shiftmetaup (org-in-subtree-not-table-p)] - ["Move Subtree Down" org-shiftmetadown (org-in-subtree-not-table-p)] + ["Move Subtree Up" org-metaup (org-at-heading-p)] + ["Move Subtree Down" org-metadown (org-at-heading-p)] "--" ["Copy Subtree" org-copy-special (org-in-subtree-not-table-p)] ["Cut Subtree" org-cut-special (org-in-subtree-not-table-p)] @@ -21012,7 +21689,7 @@ on context. See the individual commands for more information." "--" ["Set property" org-set-property (not (org-before-first-heading-p))] ["Column view of properties" org-columns t] - ["Insert Column View DBlock" org-insert-columns-dblock t]) + ["Insert Column View DBlock" org-columns-insert-dblock t]) ("Dates and Scheduling" ["Timestamp" org-time-stamp (not (org-before-first-heading-p))] ["Timestamp (inactive)" org-time-stamp-inactive (not (org-before-first-heading-p))] @@ -21073,9 +21750,7 @@ on context. See the individual commands for more information." ["Insert math symbol" cdlatex-math-symbol (fboundp 'cdlatex-math-symbol)] ["Modify math symbol" org-cdlatex-math-modify (org-inside-LaTeX-fragment-p)] - ["Insert citation" org-reftex-citation t] - "--" - ["Template for BEAMER" (org-beamer-insert-options-template) t]) + ["Insert citation" org-reftex-citation t]) "--" ("MobileOrg" ["Push Files and Views" org-mobile-push t] @@ -21101,20 +21776,20 @@ on context. See the individual commands for more information." )) (defun org-info (&optional node) - "Read documentation for Org-mode in the info system. + "Read documentation for Org in the info system. With optional NODE, go directly to that node." (interactive) (info (format "(org)%s" (or node "")))) ;;;###autoload (defun org-submit-bug-report () - "Submit a bug report on Org-mode via mail. + "Submit a bug report on Org via mail. Don't hesitate to report any problems or inaccurate documentation. If you don't have setup sending mail from (X)Emacs, please copy the output buffer into your mail program, as it gives us important -information about your Org-mode version and configuration." +information about your Org version and configuration." (interactive) (require 'reporter) (defvar reporter-prompt-for-summary-p) @@ -21126,12 +21801,12 @@ information about your Org-mode version and configuration." (org-version nil 'full) (let (list) (save-window-excursion - (org-pop-to-buffer-same-window (get-buffer-create "*Warn about privacy*")) + (pop-to-buffer-same-window (get-buffer-create "*Warn about privacy*")) (delete-other-windows) (erase-buffer) - (insert "You are about to submit a bug report to the Org-mode mailing list. + (insert "You are about to submit a bug report to the Org mailing list. -We would like to add your full Org-mode and Outline configuration to the +We would like to add your full Org and Outline configuration to the bug report. This greatly simplifies the work of the maintainer and other experts on the mailing list. @@ -21141,7 +21816,7 @@ appear in the form of file names, tags, todo states, or search strings. If you answer yes to the prompt, you might want to check and remove such private information before sending the email.") (add-text-properties (point-min) (point-max) '(face org-warning)) - (when (yes-or-no-p "Include your Org-mode configuration ") + (when (yes-or-no-p "Include your Org configuration ") (mapatoms (lambda (v) (and (boundp v) @@ -21160,11 +21835,11 @@ what in fact did happen. You don't know how to make a good report? See http://orgmode.org/manual/Feedback.html#Feedback -Your bug report will be posted to the Org-mode mailing list. +Your bug report will be posted to the Org mailing list. ------------------------------------------------------------------------") (save-excursion - (if (re-search-backward "^\\(Subject: \\)Org-mode version \\(.*?\\);[ \t]*\\(.*\\)" nil t) - (replace-match "\\1Bug: \\3 [\\2]"))))) + (when (re-search-backward "^\\(Subject: \\)Org mode version \\(.*?\\);[ \t]*\\(.*\\)" nil t) + (replace-match "\\1Bug: \\3 [\\2]"))))) (defun org-install-agenda-files-menu () @@ -21172,7 +21847,7 @@ Your bug report will be posted to the Org-mode mailing list. (save-excursion (while bl (set-buffer (pop bl)) - (if (derived-mode-p 'org-mode) (setq bl nil))) + (when (derived-mode-p 'org-mode) (setq bl nil))) (when (derived-mode-p 'org-mode) (easy-menu-change '("Org") "File List for Agenda" @@ -21190,7 +21865,7 @@ Your bug report will be posted to the Org-mode mailing list. (defun org-require-autoloaded-modules () (interactive) - (mapc 'require + (mapc #'require '(org-agenda org-archive org-attach org-clock org-colview org-id org-table org-timer))) @@ -21203,13 +21878,8 @@ With prefix arg UNCOMPILED, load the uncompiled versions." (let* ((org-dir (org-find-library-dir "org")) (contrib-dir (or (org-find-library-dir "org-contribdir") org-dir)) (feature-re "^\\(org\\|ob\\|ox\\)\\(-.*\\)?") - (remove-re (mapconcat 'identity - (mapcar (lambda (f) (concat "^" f "$")) - (list (if (featurep 'xemacs) - "org-colview" - "org-colview-xemacs") - "org" "org-loaddefs" "org-version")) - "\\|")) + (remove-re (format "\\`%s\\'" + (regexp-opt '("org" "org-loaddefs" "org-version")))) (feats (delete-dups (mapcar 'file-name-sans-extension (mapcar 'file-name-nondirectory @@ -21241,9 +21911,9 @@ With prefix arg UNCOMPILED, load the uncompiled versions." 't) f)) lfeat))) - (if load-uncore - (message "The following feature%s found in load-path, please check if that's correct:\n%s" - (if (> (length load-uncore) 1) "s were" " was") load-uncore)) + (when load-uncore + (message "The following feature%s found in load-path, please check if that's correct:\n%s" + (if (> (length load-uncore) 1) "s were" " was") load-uncore)) (if load-misses (message "Some error occurred while reloading Org feature%s\n%s\nPlease check *Messages*!\n%s" (if (> (length load-misses) 1) "s" "") load-misses (org-version nil 'full)) @@ -21258,7 +21928,7 @@ With prefix arg UNCOMPILED, load the uncompiled versions." (customize-browse 'org)) (defun org-create-customize-menu () - "Create a full customization menu for Org-mode, insert it into the menu." + "Create a full customization menu for Org mode, insert it into the menu." (interactive) (org-load-modules-maybe) (org-require-autoloaded-modules) @@ -21281,9 +21951,9 @@ With prefix arg UNCOMPILED, load the uncompiled versions." ;;; Generally useful functions -(defun org-get-at-bol (property) - "Get text property PROPERTY at 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." @@ -21291,19 +21961,9 @@ With prefix arg UNCOMPILED, load the uncompiled versions." (get-text-property (or (next-single-property-change 0 prop s) 0) prop s))) -(defun org-display-warning (message) ;; Copied from Emacs-Muse +(defun org-display-warning (message) "Display the given MESSAGE as a warning." - (if (fboundp 'display-warning) - (display-warning 'org message - (if (featurep 'xemacs) 'warning :warning)) - (let ((buf (get-buffer-create "*Org warnings*"))) - (with-current-buffer buf - (goto-char (point-max)) - (insert "Warning (Org): " message) - (unless (bolp) - (newline))) - (display-buffer buf) - (sit-for 0)))) + (display-warning 'org message :warning)) (defun org-eval (form) "Eval FORM and return result." @@ -21322,17 +21982,6 @@ With prefix arg UNCOMPILED, load the uncompiled versions." (>= (match-end 0) pos) start)))) -(defun org-in-commented-line () - "Is point in a line starting with `#'?" - (equal (char-after (point-at-bol)) ?#)) - -(defun org-in-indented-comment-line () - "Is point in a line starting with `#' after some white space?" - (save-excursion - (save-match-data - (goto-char (point-at-bol)) - (looking-at "[ \t]*#")))) - (defun org-in-verbatim-emphasis () (save-match-data (and (org-in-regexp org-emph-re 2) @@ -21340,14 +21989,35 @@ With prefix arg UNCOMPILED, load the uncompiled versions." (<= (point) (match-end 4)) (member (match-string 3) '("=" "~"))))) +(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) (buffer-live-p (marker-buffer marker))) (progn - (org-pop-to-buffer-same-window (marker-buffer marker)) - (if (or (> marker (point-max)) (< marker (point-min))) - (widen)) + (pop-to-buffer-same-window (marker-buffer marker)) + (when (or (> marker (point-max)) (< marker (point-min))) + (widen)) (goto-char marker) (org-show-context 'org-goto)) (if bookmark @@ -21390,7 +22060,7 @@ upon the next fontification round." l)) (defun org-shorten-string (s maxlength) - "Shorten string S so tht it is no longer than MAXLENGTH characters. + "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 @@ -21410,8 +22080,8 @@ if necessary." "Get the indentation of the current line, interpreting tabs. When LINE is given, assume it represents a line and compute its indentation." (if line - (if (string-match "^ *" (org-remove-tabs line)) - (match-end 0)) + (when (string-match "^ *" (org-remove-tabs line)) + (match-end 0)) (save-excursion (beginning-of-line 1) (skip-chars-forward " \t") @@ -21448,35 +22118,45 @@ 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))) - (if (>= i i2) (setq l (substring line i2))) + (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 the maximum common indentation from the lines in CODE. -N may optionally be the number of spaces to remove." + "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) - (org-do-remove-indentation n) - (buffer-string))) + (if (org-do-remove-indentation n) (buffer-string) code))) (defun org-do-remove-indentation (&optional n) - "Remove the maximum common indentation from the buffer." - (untabify (point-min) (point-max)) - (let ((min 10000) re) - (if n - (setq min n) - (goto-char (point-min)) - (while (re-search-forward "^ *[^ \n]" nil t) - (setq min (min min (1- (- (match-end 0) (match-beginning 0))))))) - (unless (or (= min 0) (= min 10000)) - (setq re (format "^ \\{%d\\}" min)) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (replace-match "") - (end-of-line 1)) - min))) + "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." @@ -21496,12 +22176,6 @@ N may optionally be the number of spaces to remove." (or (buffer-base-buffer buffer) buffer))) -(defun org-trim (s) - "Remove whitespace at beginning and end of string." - (if (string-match "\\`[ \t\n\r]+" s) (setq s (replace-match "" t t s))) - (if (string-match "[ \t\n\r]+\\'" s) (setq s (replace-match "" 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 @@ -21539,13 +22213,12 @@ The return value is a list of lines, without newlines at the end." (defun org-split-string (string &optional separators) "Splits STRING into substrings at SEPARATORS. +SEPARATORS is a regular expression. No empty strings are returned if there are matches at the beginning and end of string." - (let ((rexp (or separators "[ \f\t\n\r\v]+")) - (start 0) - notfirst - (list nil)) - (while (and (string-match rexp string + ;; FIXME: why not use (split-string STRING SEPARATORS t)? + (let ((start 0) notfirst list) + (while (and (string-match (or separators "[ \f\t\n\r\v]+") string (if (and notfirst (= start (match-beginning 0)) (< start (length string))) @@ -21555,14 +22228,10 @@ and end of string." (or (eq (match-beginning 0) 0) (and (eq (match-beginning 0) (match-end 0)) (eq (match-beginning 0) start)) - (setq list - (cons (substring string start (match-beginning 0)) - list))) + (push (substring string start (match-beginning 0)) list)) (setq start (match-end 0))) (or (eq start (length string)) - (setq list - (cons (substring string start) - list))) + (push (substring string start) list)) (nreverse list))) (defun org-quote-vert (s) @@ -21579,10 +22248,8 @@ and end of string." "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." - (let ((case-fold-search t) ov) - (or (and (setq ov (overlays-at (point))) - (memq 'org-block-background - (overlay-properties (car ov)))) + (let ((case-fold-search t)) + (or (and (eq (get-char-property (point) 'src-block) t)) (and (not inside) (save-match-data (save-excursion @@ -21604,13 +22271,13 @@ contexts are: :item on the first line of a plain list item :item-bullet on the bullet/number of a plain list item :checkbox on the checkbox in a plain list item -:table in an org-mode table +:table in an Org table :table-special on a special filed in a table :table-table in a table.el table :clocktable in a clocktable :src-block in a source block :link on a hyperlink -:keyword on a keyword: SCHEDULED, DEADLINE, CLOSE, COMMENT, QUOTE. +:keyword on a keyword: SCHEDULED, DEADLINE, CLOSE, COMMENT. :target on a <<target>> :radio-target on a <<<radio-target>>> :latex-fragment on a LaTeX fragment @@ -21635,8 +22302,8 @@ and :keyword." (push (org-point-in-group p 4 :tags) clist)) (goto-char p) (skip-chars-backward "^[\n\r \t") (or (bobp) (backward-char 1)) - (if (looking-at "\\[#[A-Z0-9]\\]") - (push (org-point-in-group p 0 :priority) clist))) + (when (looking-at "\\[#[A-Z0-9]\\]") + (push (org-point-in-group p 0 :priority) clist))) ((org-at-item-p) (push (org-point-in-group p 2 :item-bullet) clist) @@ -21648,10 +22315,10 @@ and :keyword." ((org-at-table-p) (push (list :table (org-table-begin) (org-table-end)) clist) - (if (memq 'org-formula faces) - (push (list :table-special - (previous-single-property-change p 'face) - (next-single-property-change p 'face)) clist))) + (when (memq 'org-formula faces) + (push (list :table-special + (previous-single-property-change p 'face) + (next-single-property-change p 'face)) clist))) ((org-at-table-p 'any) (push (list :table-table) clist))) (goto-char p) @@ -21660,16 +22327,16 @@ and :keyword." ;; New the "medium" contexts: clocktables, source blocks (cond ((org-in-clocktable-p) (push (list :clocktable - (and (or (looking-at "#\\+BEGIN: clocktable") - (search-backward "#+BEGIN: clocktable" nil t)) - (match-beginning 0)) - (and (re-search-forward "#\\+END:?" nil t) + (and (or (looking-at "[ \t]*\\(#\\+BEGIN: clocktable\\)") + (re-search-backward "[ \t]*\\(#+BEGIN: clocktable\\)" nil t)) + (match-beginning 1)) + (and (re-search-forward "[ \t]*#\\+END:?" nil t) (match-end 0))) clist)) ((org-in-src-block-p) (push (list :src-block - (and (or (looking-at "#\\+BEGIN_SRC") - (search-backward "#+BEGIN_SRC" nil t)) - (match-beginning 0)) + (and (or (looking-at "[ \t]*\\(#\\+BEGIN_SRC\\)") + (re-search-backward "[ \t]*\\(#+BEGIN_SRC\\)" nil t)) + (match-beginning 1)) (and (search-forward "#+END_SRC" nil t) (match-beginning 0))) clist)))) (goto-char p) @@ -21689,14 +22356,14 @@ and :keyword." ((org-at-target-p) (push (org-point-in-group p 0 :target) clist) (goto-char (1- (match-beginning 0))) - (if (looking-at org-radio-target-regexp) - (push (org-point-in-group p 0 :radio-target) clist)) + (when (looking-at org-radio-target-regexp) + (push (org-point-in-group p 0 :radio-target) clist)) (goto-char p)) - ((setq o (car (delq nil - (mapcar - (lambda (x) - (if (memq x org-latex-fragment-image-overlays) x)) - (overlays-at (point)))))) + ((setq o (cl-some + (lambda (o) + (and (eq (overlay-get o 'org-overlay-type) 'org-latex-overlay) + o)) + (overlays-at (point)))) (push (list :latex-fragment (overlay-start o) (overlay-end o)) clist) (push (list :latex-preview @@ -21708,35 +22375,27 @@ and :keyword." (setq clist (nreverse (delq nil clist))) clist)) -;; FIXME: Compare with at-regexp-p Do we need both? -(defun org-in-regexp (re &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 both before and after 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." - (catch 'exit +(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 (point-at-eol (+ 1 (or nlines 0)))) - (inc (if visually 1 0))) + (eol (line-end-position (if nlines (1+ nlines) 1)))) (save-excursion (beginning-of-line (- 1 (or nlines 0))) - (while (re-search-forward re eol t) - (if (and (<= (match-beginning 0) pos) - (>= (+ inc (match-end 0)) pos)) - (throw 'exit (cons (match-beginning 0) (match-end 0))))))))) - -(defun org-at-regexp-p (regexp) - "Is point inside a match of REGEXP in the current line?" - (catch 'exit - (save-excursion - (let ((pos (point)) (end (point-at-eol))) - (beginning-of-line 1) - (while (re-search-forward regexp end t) - (if (and (<= (match-beginning 0) pos) - (>= (match-end 0) pos)) - (throw 'exit t))) - nil)))) + (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. @@ -21757,7 +22416,7 @@ position before START-RE (resp. after END-RE)." (save-excursion ;; Point is on a block when on START-RE or if START-RE can be ;; found before it... - (and (or (org-at-regexp-p start-re) + (and (or (org-in-regexp start-re) (re-search-backward start-re limit-up t)) (setq beg (match-beginning 0)) ;; ... and END-RE after it... @@ -21783,27 +22442,15 @@ block from point." (let ((case-fold-search t) (lim-up (save-excursion (outline-previous-heading))) (lim-down (save-excursion (outline-next-heading)))) - (mapc (lambda (name) - (let ((n (regexp-quote name))) - (when (org-between-regexps-p - (concat "^[ \t]*#\\+begin_" n) - (concat "^[ \t]*#\\+end_" n) - lim-up lim-down) - (throw 'exit n)))) - names)) + (dolist (name names) + (let ((n (regexp-quote name))) + (when (org-between-regexps-p + (concat "^[ \t]*#\\+begin_" n) + (concat "^[ \t]*#\\+end_" n) + lim-up lim-down) + (throw 'exit n))))) nil))) -(defun org-in-drawer-p () - "Is point within a drawer?" - (save-match-data - (let ((case-fold-search t) - (lim-up (save-excursion (outline-previous-heading))) - (lim-down (save-excursion (outline-next-heading)))) - (org-between-regexps-p - (concat "^[ \t]*:" (regexp-opt org-drawers) ":") - "^[ \t]*:end:.*$" - lim-up lim-down)))) - (defun org-occur-in-agenda-files (regexp &optional _nlines) "Call `multi-occur' with buffers for all agenda files." (interactive "sOrg-files matching: ") @@ -21815,40 +22462,21 @@ block from point." (setq files (org-add-archive-files files))) (dolist (f extra) (unless (member (file-truename f) tnames) - (unless (member f files) (setq files (append files (list f)))) - (setq tnames (append tnames (list (file-truename f)))))) + (unless (member f files) (setq files (append files (list f)))) + (setq tnames (append tnames (list (file-truename f)))))) (multi-occur (mapcar (lambda (x) (with-current-buffer - ;; FIXME: Why not just (find-file-noselect x)? - ;; Is it to avoid the "revert buffer" prompt? + ;; FIXME: Why not just (find-file-noselect x)? + ;; Is it to avoid the "revert buffer" prompt? (or (get-file-buffer x) (find-file-noselect x)) (widen) (current-buffer))) files) regexp))) -(if (boundp 'occur-mode-find-occurrence-hook) - ;; Emacs 23 - (add-hook 'occur-mode-find-occurrence-hook - (lambda () - (when (derived-mode-p 'org-mode) - (org-reveal)))) - ;; Emacs 22 - (defadvice occur-mode-goto-occurrence - (after org-occur-reveal activate) - (and (derived-mode-p 'org-mode) (org-reveal))) - (defadvice occur-mode-goto-occurrence-other-window - (after org-occur-reveal activate) - (and (derived-mode-p 'org-mode) (org-reveal))) - (defadvice occur-mode-display-occurrence - (after org-occur-reveal activate) - (when (derived-mode-p 'org-mode) - (let ((pos (occur-mode-find-occurrence))) - (with-current-buffer (marker-buffer pos) - (save-excursion - (goto-char pos) - (org-reveal))))))) +(add-hook 'occur-mode-find-occurrence-hook + (lambda () (when (derived-mode-p 'org-mode) (org-reveal)))) (defun org-occur-link-in-agenda-files () "Create a link and search for it in the agendas. @@ -21878,81 +22506,27 @@ merge (a 1) and (a 3) into (a 1 3). The function returns the new ALIST." (let (rtn) - (mapc - (lambda (e) - (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)))) - alist) - 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." + "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-count (cl-item cl-seq) - "Count the number of occurrences of ITEM in SEQ. -Taken from `count' in cl-seq.el with all keyword arguments removed." - (let ((cl-end (length cl-seq)) (cl-start 0) (cl-count 0) cl-x) - (when (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) - (while (< cl-start cl-end) - (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) - (if (equal cl-item cl-x) (setq cl-count (1+ cl-count))) - (setq cl-start (1+ cl-start))) - cl-count)) - -(defun org-remove-if (predicate seq) - "Remove everything from SEQ that fulfills PREDICATE." - (let (res e) - (while seq - (setq e (pop seq)) - (if (not (funcall predicate e)) (push e res))) - (nreverse res))) - -(defun org-remove-if-not (predicate seq) - "Remove everything from SEQ that does not fulfill PREDICATE." - (let (res e) - (while seq - (setq e (pop seq)) - (if (funcall predicate e) (push e res))) - (nreverse res))) - -(defun org-reduce (cl-func cl-seq &rest cl-keys) - "Reduce two-argument FUNCTION across SEQ. -Taken from `reduce' in cl-seq.el with all keyword arguments but -\":initial-value\" removed." - (let ((cl-accum (cond ((memq :initial-value cl-keys) - (cadr (memq :initial-value cl-keys))) - (cl-seq (pop cl-seq)) - (t (funcall cl-func))))) - (while cl-seq - (setq cl-accum (funcall cl-func cl-accum (pop cl-seq)))) - cl-accum)) - -(defun org-every (pred seq) - "Return true if PREDICATE is true of every element of SEQ. -Adapted from `every' in cl.el." - (catch 'org-every - (mapc (lambda (e) (unless (funcall pred e) (throw 'org-every nil))) seq) - t)) - -(defun org-some (pred seq) - "Return true if PREDICATE is true of any element of SEQ. -Adapted from `some' in cl.el." - (catch 'org-some - (mapc (lambda (e) (when (funcall pred e) (throw 'org-some t))) seq) - nil)) - (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." (let ((pos (point))) - (if (cdr (assoc 'heading org-blank-before-new-entry)) + (if (cdr (assq 'heading org-blank-before-new-entry)) (skip-chars-backward " \t\n\r") (unless (eobp) (forward-line -1))) @@ -22005,7 +22579,7 @@ so values can contain further %-escapes if they are define later in TABLE." (let ((tbl (copy-alist table)) (case-fold-search nil) (pchg 0) - e re rpl) + re rpl) (dolist (e tbl) (setq re (concat "%-?[0-9.]*" (substring (car e) 1))) (when (and (cdr e) (string-match re (cdr e))) @@ -22023,16 +22597,6 @@ so values can contain further %-escapes if they are define later in TABLE." (setq string (replace-match sref t t string))))) string)) -(defun org-sublist (list start end) - "Return a section of LIST, from START to END. -Counting starts at 1." - (let (rtn (c start)) - (setq list (nthcdr (1- start) list)) - (while (and list (<= c end)) - (push (pop list) rtn) - (setq c (1+ c))) - (nreverse rtn))) - (defun org-find-base-buffer-visiting (file) "Like `find-buffer-visiting' but always return the base buffer and not an indirect buffer." @@ -22042,26 +22606,12 @@ not an indirect buffer." (or (buffer-base-buffer buf) buf) nil))) -(defun org-image-file-name-regexp (&optional extensions) - "Return regexp matching the file names of images. -If EXTENSIONS is given, only match these." - (if (and (not extensions) (fboundp 'image-file-name-regexp)) - (image-file-name-regexp) - (let ((image-file-name-extensions - (or extensions - '("png" "jpeg" "jpg" "gif" "tiff" "tif" - "xbm" "xpm" "pbm" "pgm" "ppm")))) - (concat "\\." - (regexp-opt (nconc (mapcar 'upcase - image-file-name-extensions) - image-file-name-extensions) - t) - "\\'")))) - -(defun org-file-image-p (file &optional extensions) +;;; TODO: Only called once, from ox-odt which should probably use +;;; org-export-inline-image-p or something. +(defun org-file-image-p (file) "Return non-nil if FILE is an image." (save-match-data - (string-match (org-image-file-name-regexp extensions) file))) + (string-match (image-file-name-regexp) file))) (defun org-get-cursor-date (&optional with-time) "Return the date at cursor in as a time. @@ -22085,10 +22635,10 @@ the agenda) or the current time of the day." (nth 1 date) (nth 0 date) (nth 2 date)))) ((eq major-mode 'org-agenda-mode) (setq day (get-text-property (point) 'day)) - (if day - (setq date (calendar-gregorian-from-absolute day) - defd (encode-time 0 (or mod 0) (or hod 0) - (nth 1 date) (nth 0 date) (nth 2 date)))))) + (when day + (setq date (calendar-gregorian-from-absolute day) + defd (encode-time 0 (or mod 0) (or hod 0) + (nth 1 date) (nth 0 date) (nth 2 date)))))) (or defd (current-time)))) (defun org-mark-subtree (&optional up) @@ -22101,177 +22651,440 @@ hierarchy of headlines by UP levels before marking the subtree." (cond ((org-at-heading-p) (beginning-of-line)) ((org-before-first-heading-p) (user-error "Not in a subtree")) (t (outline-previous-visible-heading 1)))) - (when up (while (and (> up 0) (org-up-heading-safe)) (decf up))) - (if (org-called-interactively-p 'any) + (when up (while (and (> up 0) (org-up-heading-safe)) (cl-decf up))) + (if (called-interactively-p 'any) (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 (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)))) + (_ (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) +(defun org--get-expected-indentation (element contentsp) + "Expected indentation column for current line, according to ELEMENT. +ELEMENT is an element containing point. CONTENTSP is non-nil +when indentation is to be computed according to contents of +ELEMENT." + (let ((type (org-element-type element)) + (start (org-element-property :begin element)) + (post-affiliated (org-element-property :post-affiliated element))) + (org-with-wide-buffer + (cond + (contentsp + (cl-case type + ((diary-sexp footnote-definition) 0) + ((headline inlinetask nil) + (if (not org-adapt-indentation) 0 + (let ((level (org-current-level))) + (if level (1+ level) 0)))) + ((item plain-list) (org-list-item-body-column post-affiliated)) + (t + (goto-char start) + (org-get-indentation)))) + ((memq type '(headline inlinetask nil)) + (if (org-match-line "[ \t]*$") + (org--get-expected-indentation element t) + 0)) + ((memq type '(diary-sexp footnote-definition)) 0) + ;; First paragraph of a footnote definition or an item. + ;; Indent like parent. + ((< (line-beginning-position) start) + (org--get-expected-indentation + (org-element-property :parent element) t)) + ;; At first line: indent according to previous sibling, if any, + ;; ignoring footnote definitions and inline tasks, or parent's + ;; contents. + ((= (line-beginning-position) start) + (catch 'exit + (while t + (if (= (point-min) start) (throw 'exit 0) + (goto-char (1- start)) + (let* ((previous (org-element-at-point)) + (parent previous)) + (while (and parent (<= (org-element-property :end parent) start)) + (setq previous parent + parent (org-element-property :parent parent))) + (cond + ((not previous) (throw 'exit 0)) + ((> (org-element-property :end previous) start) + (throw 'exit (org--get-expected-indentation previous t))) + ((memq (org-element-type previous) + '(footnote-definition inlinetask)) + (setq start (org-element-property :begin previous))) + (t (goto-char (org-element-property :begin previous)) + (throw 'exit + (if (bolp) (org-get-indentation) + ;; At first paragraph in an item or + ;; a footnote definition. + (org--get-expected-indentation + (org-element-property :parent previous) t)))))))))) + ;; Otherwise, move to the first non-blank line above. + (t + (beginning-of-line) + (let ((pos (point))) + (skip-chars-backward " \r\t\n") + (cond + ;; Two blank lines end a footnote definition or a plain + ;; list. When we indent an empty line after them, the + ;; containing list or footnote definition is over, so it + ;; qualifies as a previous sibling. Therefore, we indent + ;; like its first line. + ((and (memq type '(footnote-definition plain-list)) + (> (count-lines (point) pos) 2)) + (goto-char start) + (org-get-indentation)) + ;; Line above is the first one of a paragraph at the + ;; beginning of an item or a footnote definition. Indent + ;; like parent. + ((< (line-beginning-position) start) + (org--get-expected-indentation + (org-element-property :parent element) t)) + ;; Line above is the beginning of an element, i.e., point + ;; was originally on the blank lines between element's start + ;; and contents. + ((= (line-beginning-position) post-affiliated) + (org--get-expected-indentation element t)) + ;; POS is after contents in a greater element. Indent like + ;; the beginning of the element. + ((and (memq type org-element-greater-elements) + (let ((cend (org-element-property :contents-end element))) + (and cend (<= cend pos)))) + ;; As a special case, if point is at the end of a footnote + ;; definition or an item, indent like the very last element + ;; within. If that last element is an item, indent like + ;; its contents. + (if (memq type '(footnote-definition item plain-list)) + (let ((last (org-element-at-point))) + (goto-char pos) + (org--get-expected-indentation + last (eq (org-element-type last) 'item))) + (goto-char start) + (org-get-indentation))) + ;; In any other case, indent like the current line. + (t (org-get-indentation))))))))) + +(defun org--align-node-property () + "Align node property at point. +Alignment is done according to `org-property-format', which see." + (when (save-excursion + (beginning-of-line) + (looking-at org-property-re)) + (replace-match + (concat (match-string 4) + (org-trim + (format org-property-format (match-string 1) (match-string 3)))) + t t))) + (defun org-indent-line () - "Indent line depending on context." + "Indent line depending on context. + +Indentation is done according to the following rules: + + - Footnote definitions, diary sexps, headlines and inline tasks + have to start at column 0. + + - On the very first line of an element, consider, in order, the + next rules until one matches: + + 1. If there's a sibling element before, ignoring footnote + 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. + + 3. Otherwise, indent relatively to current level, if + `org-adapt-indentation' is non-nil, or to left margin. + + - On a blank line at the end of an element, indent according to + the type of the element. More precisely + + 1. If element is a plain list, an item, or a footnote + definition, indent like the very last element within. + + 2. If element is a paragraph, indent like its last non blank + line. + + 3. Otherwise, indent like its very first line. + + - In the code part of a source block, use language major mode + to indent current line if `org-src-tab-acts-natively' is + non-nil. If it is nil, do nothing. + + - Otherwise, indent like the first non-blank line above. + +The function doesn't indent an item as it could break the whole +list structure. Instead, use \\<org-mode-map>`\\[org-shiftmetaleft]' or \ +`\\[org-shiftmetaright]'. + +Also align node properties according to `org-property-format'." (interactive) - (let* ((pos (point)) - (itemp (org-at-item-p)) - (case-fold-search t) - (org-drawer-regexp (or org-drawer-regexp "\000")) - (inline-task-p (and (featurep 'org-inlinetask) - (org-inlinetask-in-task-p))) - (inline-re (and inline-task-p - (org-inlinetask-outline-regexp))) - column) - (if (and orgstruct-is-++ (eq pos (point))) - (let ((indent-line-function (cadadr (assoc 'indent-line-function org-fb-vars)))) - (indent-according-to-mode)) - (beginning-of-line 1) - (cond - ;; Headings - ((looking-at org-outline-regexp) (setq column 0)) - ;; Footnote definition - ((looking-at org-footnote-definition-re) (setq column 0)) - ;; Literal examples - ((looking-at "[ \t]*:\\( \\|$\\)") - (setq column (org-get-indentation))) ; do nothing - ;; Lists - ((ignore-errors (goto-char (org-in-item-p))) - (setq column (if itemp - (org-get-indentation) - (org-list-item-body-column (point)))) - (goto-char pos)) - ;; Drawers - ((and (looking-at "[ \t]*:END:") - (save-excursion (re-search-backward org-drawer-regexp nil t))) - (save-excursion - (goto-char (1- (match-beginning 1))) - (setq column (current-column)))) - ;; Special blocks - ((and (looking-at "[ \t]*#\\+end_\\([a-z]+\\)") - (save-excursion - (re-search-backward - (concat "^[ \t]*#\\+begin_" (downcase (match-string 1))) nil t))) - (setq column (org-get-indentation (match-string 0)))) - ((and (not (looking-at "[ \t]*#\\+begin_")) - (org-between-regexps-p "^[ \t]*#\\+begin_" "[ \t]*#\\+end_")) - (save-excursion - (re-search-backward "^[ \t]*#\\+begin_\\([a-z]+\\)" nil t)) - (setq column - (cond ((equal (downcase (match-string 1)) "src") - ;; src blocks: let `org-edit-src-exit' handle them - (org-get-indentation)) - ((equal (downcase (match-string 1)) "example") - (max (org-get-indentation) - (org-get-indentation (match-string 0)))) - (t - (org-get-indentation (match-string 0)))))) - ;; This line has nothing special, look at the previous relevant - ;; line to compute indentation - (t - (beginning-of-line 0) - (while (and (not (bobp)) - (not (looking-at org-table-line-regexp)) - (not (looking-at org-drawer-regexp)) - ;; When point started in an inline task, do not move - ;; above task starting line. - (not (and inline-task-p (looking-at inline-re))) - ;; Skip drawers, blocks, empty lines, verbatim, - ;; comments, tables, footnotes definitions, lists, - ;; inline tasks. - (or (and (looking-at "[ \t]*:END:") - (re-search-backward org-drawer-regexp nil t)) - (and (looking-at "[ \t]*#\\+end_") - (re-search-backward "[ \t]*#\\+begin_"nil t)) - (looking-at "[ \t]*[\n:#|]") - (looking-at org-footnote-definition-re) - (and (not inline-task-p) - (featurep 'org-inlinetask) - (org-inlinetask-in-task-p) - (or (org-inlinetask-goto-beginning) t)))) - (beginning-of-line 0)) - (cond - ;; There was a list item above. - ((ignore-errors (goto-char (org-in-item-p))) - (goto-char (org-list-get-top-point (org-list-struct))) - (setq column (org-get-indentation))) - ;; There was an heading above. - ((looking-at "\\*+[ \t]+") - (if (not org-adapt-indentation) - (setq column 0) - (goto-char (match-end 0)) - (setq column (current-column)))) - ;; A drawer had started and is unfinished - ((looking-at org-drawer-regexp) - (goto-char (1- (match-beginning 1))) - (setq column (current-column))) - ;; Else, nothing noticeable found: get indentation and go on. - (t (setq column (org-get-indentation)))))) - ;; Now apply indentation and move cursor accordingly - (goto-char pos) - (if (<= (current-column) (current-indentation)) - (org-indent-line-to column) - (save-excursion (org-indent-line-to column))) - ;; Special polishing for properties, see `org-property-format' - (setq column (current-column)) - (beginning-of-line 1) - (if (looking-at org-property-re) - (replace-match (concat (match-string 4) - (format org-property-format - (match-string 1) (match-string 3))) - t t)) - (org-move-to-column column)))) + (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))) + (type (org-element-type element))) + (cond ((and (memq type '(plain-list item)) + (= (line-beginning-position) + (org-element-property :post-affiliated element))) + 'noindent) + ((and (eq type 'latex-environment) + (>= (point) (org-element-property :post-affiliated element)) + (< (point) (org-with-wide-buffer + (goto-char (org-element-property :end element)) + (skip-chars-backward " \r\t\n") + (line-beginning-position 2)))) + 'noindent) + ((and (eq type 'src-block) + org-src-tab-acts-natively + (> (line-beginning-position) + (org-element-property :post-affiliated element)) + (< (line-beginning-position) + (org-with-wide-buffer + (goto-char (org-element-property :end element)) + (skip-chars-backward " \r\t\n") + (line-beginning-position)))) + (org-babel-do-key-sequence-in-edit-buffer (kbd "TAB"))) + (t + (let ((column (org--get-expected-indentation element nil))) + ;; Preserve current column. + (if (<= (current-column) (current-indentation)) + (indent-line-to column) + (save-excursion (indent-line-to column)))) + ;; Align node property. Also preserve current column. + (when (eq type 'node-property) + (let ((column (current-column))) + (org--align-node-property) + (org-move-to-column column))))))))) + +(defun org-indent-region (start end) + "Indent each non-blank line in the region. +Called from a program, START and END specify the region to +indent. The function will not indent contents of example blocks, +verse blocks and export blocks as leading white spaces are +assumed to be significant there." + (interactive "r") + (save-excursion + (goto-char start) + (skip-chars-forward " \r\t\n") + (unless (eobp) (beginning-of-line)) + (let ((indent-to + (lambda (ind pos) + ;; Set IND as indentation for all lines between point and + ;; POS. Blank lines are ignored. Leave point after POS + ;; once done. + (let ((limit (copy-marker pos))) + (while (< (point) limit) + (unless (looking-at-p "[ \t]*$") (indent-line-to ind)) + (forward-line)) + (set-marker limit nil)))) + (end (copy-marker end))) + (while (< (point) end) + (if (or (looking-at-p " \r\t\n") (org-at-heading-p)) (forward-line) + (let* ((element (org-element-at-point)) + (type (org-element-type element)) + (element-end (copy-marker (org-element-property :end element))) + (ind (org--get-expected-indentation element nil))) + (cond + ;; Element indented as a single block. Example blocks + ;; preserving indentation are a special case since the + ;; "contents" must not be indented whereas the block + ;; boundaries can. + ((or (memq type '(export-block latex-environment)) + (and (eq type 'example-block) + (not + (or org-src-preserve-indentation + (org-element-property :preserve-indent element))))) + (let ((offset (- ind (org-get-indentation)))) + (unless (zerop offset) + (indent-rigidly (org-element-property :begin element) + (org-element-property :end element) + offset))) + (goto-char element-end)) + ;; Elements indented line wise. Be sure to exclude + ;; example blocks (preserving indentation) and source + ;; blocks from this category as they are treated + ;; specially later. + ((or (memq type '(paragraph table table-row)) + (not (or (org-element-property :contents-begin element) + (memq type '(example-block src-block))))) + (when (eq type 'node-property) + (org--align-node-property) + (beginning-of-line)) + (funcall indent-to ind (min element-end end))) + ;; Elements consisting of three parts: before the + ;; contents, the contents, and after the contents. The + ;; contents are treated specially, according to the + ;; element type, or not indented at all. Other parts are + ;; indented as a single block. + (t + (let* ((post (copy-marker + (org-element-property :post-affiliated element))) + (cbeg + (copy-marker + (cond + ((not (org-element-property :contents-begin element)) + ;; Fake contents for source blocks. + (org-with-wide-buffer + (goto-char post) + (line-beginning-position 2))) + ((memq type '(footnote-definition item plain-list)) + ;; Contents in these elements could start on + ;; the same line as the beginning of the + ;; element. Make sure we start indenting + ;; from the second line. + (org-with-wide-buffer + (goto-char post) + (end-of-line) + (skip-chars-forward " \r\t\n") + (if (eobp) (point) (line-beginning-position)))) + (t (org-element-property :contents-begin element))))) + (cend (copy-marker + (or (org-element-property :contents-end element) + ;; Fake contents for source blocks. + (org-with-wide-buffer + (goto-char element-end) + (skip-chars-backward " \r\t\n") + (line-beginning-position))) + t))) + ;; Do not change items indentation individually as it + ;; 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)))) + (unless (zerop offset) + (indent-rigidly (org-element-property :begin element) + (org-element-property :end element) + offset)) + (goto-char cbeg))) + ((eq type 'item) (goto-char cbeg)) + (t (funcall indent-to ind (min cbeg end)))) + (when (< (point) end) + (cl-case type + ((example-block verse-block)) + (src-block + ;; In a source block, indent source code + ;; according to language major mode, but only if + ;; `org-src-tab-acts-natively' is non-nil. + (when (and (< (point) end) org-src-tab-acts-natively) + (ignore-errors + (org-babel-do-in-edit-buffer + (indent-region (point-min) (point-max)))))) + (t (org-indent-region (point) (min cend end)))) + (goto-char (min cend end)) + (when (< (point) end) + (funcall indent-to ind (min element-end end)))) + (set-marker post nil) + (set-marker cbeg nil) + (set-marker cend nil)))) + (set-marker element-end nil)))) + (set-marker end nil)))) (defun org-indent-drawer () "Indent the drawer at point." (interactive) - (let ((p (point)) - (e (and (save-excursion (re-search-forward ":END:" nil t)) - (match-end 0))) - (folded - (save-excursion - (end-of-line) - (when (overlays-at (point)) - (member 'invisible (overlay-properties - (car (overlays-at (point))))))))) - (when folded (org-cycle)) - (indent-for-tab-command) - (while (and (move-beginning-of-line 2) (< (point) e)) - (indent-for-tab-command)) - (goto-char p) - (when folded (org-cycle))) + (unless (save-excursion + (beginning-of-line) + (looking-at-p org-drawer-regexp)) + (user-error "Not at a drawer")) + (let ((element (org-element-at-point))) + (unless (memq (org-element-type element) '(drawer property-drawer)) + (user-error "Not at a drawer")) + (org-with-wide-buffer + (org-indent-region (org-element-property :begin element) + (org-element-property :end element)))) (message "Drawer at point indented")) (defun org-indent-block () "Indent the block at point." (interactive) - (let ((p (point)) - (case-fold-search t) - (e (and (save-excursion (re-search-forward "#\\+end_?\\(?:[a-z]+\\)?" nil t)) - (match-end 0))) - (folded - (save-excursion - (end-of-line) - (when (overlays-at (point)) - (member 'invisible (overlay-properties - (car (overlays-at (point))))))))) - (when folded (org-cycle)) - (indent-for-tab-command) - (while (and (move-beginning-of-line 2) (< (point) e)) - (indent-for-tab-command)) - (goto-char p) - (when folded (org-cycle))) + (unless (save-excursion + (beginning-of-line) + (let ((case-fold-search t)) + (looking-at-p "[ \t]*#\\+\\(begin\\|end\\)_"))) + (user-error "Not at a block")) + (let ((element (org-element-at-point))) + (unless (memq (org-element-type element) + '(comment-block center-block dynamic-block example-block + export-block quote-block special-block + src-block verse-block)) + (user-error "Not at a block")) + (org-with-wide-buffer + (org-indent-region (org-element-property :begin element) + (org-element-property :end element)))) (message "Block at point indented")) -(defun org-indent-region (start end) - "Indent region." - (interactive "r") - (save-excursion - (let ((line-end (org-current-line end))) - (goto-char start) - (while (< (org-current-line) line-end) - (cond ((org-in-src-block-p t) (org-src-native-tab-command-maybe)) - (t (call-interactively 'org-indent-line))) - (move-beginning-of-line 2))))) - ;;; Filling @@ -22294,20 +23107,20 @@ hierarchy of headlines by UP levels before marking the subtree." (require 'org-element) ;; Prevent auto-fill from inserting unwanted new items. (when (boundp 'fill-nobreak-predicate) - (org-set-local - 'fill-nobreak-predicate + (setq-local + fill-nobreak-predicate (org-uniquify (append fill-nobreak-predicate '(org-fill-line-break-nobreak-p org-fill-paragraph-with-timestamp-nobreak-p))))) (let ((paragraph-ending (substring org-element-paragraph-separate 1))) - (org-set-local 'paragraph-start paragraph-ending) - (org-set-local 'paragraph-separate paragraph-ending)) - (org-set-local 'fill-paragraph-function 'org-fill-paragraph) - (org-set-local 'auto-fill-inhibit-regexp nil) - (org-set-local 'adaptive-fill-function 'org-adaptive-fill-function) - (org-set-local 'normal-auto-fill-function 'org-auto-fill-function) - (org-set-local 'comment-line-break-function 'org-comment-line-break-function)) + (setq-local paragraph-start paragraph-ending) + (setq-local paragraph-separate paragraph-ending)) + (setq-local fill-paragraph-function 'org-fill-paragraph) + (setq-local auto-fill-inhibit-regexp nil) + (setq-local adaptive-fill-function 'org-adaptive-fill-function) + (setq-local normal-auto-fill-function 'org-auto-fill-function) + (setq-local comment-line-break-function 'org-comment-line-break-function)) (defun org-fill-line-break-nobreak-p () "Non-nil when a new line at point would create an Org line break." @@ -22332,69 +23145,64 @@ matches in paragraphs or comments, use it." (when (derived-mode-p 'message-mode) (save-excursion (beginning-of-line) - (cond ((or (not (message-in-body-p)) - (looking-at orgtbl-line-start-regexp)) - (throw 'exit nil)) + (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)) ? )))))) + (throw 'exit (make-string (length (match-string 0)) ?\s)))))) (org-with-wide-buffer - (let* ((p (line-beginning-position)) - (element (save-excursion - (beginning-of-line) - (or (ignore-errors (org-element-at-point)) - (user-error "An element cannot be parsed line %d" - (line-number-at-pos (point)))))) - (type (org-element-type element)) - (post-affiliated (org-element-property :post-affiliated element))) - (unless (and post-affiliated (< p post-affiliated)) - (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 - (or post-affiliated - (org-element-property :begin element))) - ? )) - (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))) + (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) - (cond ((eq (org-element-type parent) 'item) - (make-string (org-list-item-body-column - (org-element-property :begin parent)) - ? )) - ((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) - "")))))))))) + (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" ()) (defvar message-cite-prefix-regexp) ; From message.el @@ -22420,11 +23228,11 @@ a footnote definition, try to fill the first paragraph within." (looking-at message-cite-prefix-regexp)))) ;; First ensure filling is correct in message-mode. (let ((fill-paragraph-function - (cadadr (assoc 'fill-paragraph-function org-fb-vars))) - (fill-prefix (cadadr (assoc 'fill-prefix org-fb-vars))) - (paragraph-start (cadadr (assoc 'paragraph-start org-fb-vars))) + (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 - (cadadr (assoc 'paragraph-separate org-fb-vars)))) + (cl-cadadr (assq 'paragraph-separate org-fb-vars)))) (fill-paragraph nil)) (with-syntax-table org-mode-transpose-word-syntax-table ;; Move to end of line in order to get the first paragraph @@ -22436,7 +23244,7 @@ a footnote definition, try to fill the first paragraph within." (line-number-at-pos (point))))))) ;; First check if point is in a blank line at the beginning of ;; the buffer. In that case, ignore filling. - (case (org-element-type element) + (cl-case (org-element-type element) ;; Use major mode filling function is src blocks. (src-block (org-babel-do-key-sequence-in-edit-buffer (kbd "M-q"))) ;; Align Org tables, leave table.el tables as-is. @@ -22465,25 +23273,18 @@ a footnote definition, try to fill the first paragraph within." (concat "^" message-cite-prefix-regexp) end t)) (setq end (match-beginning 0)))) ;; Fill paragraph, taking line breaks into account. - ;; For that, slice the paragraph using line breaks as - ;; separators, and fill the parts in reverse order to - ;; avoid messing with markers. (save-excursion - (goto-char end) - (mapc - (lambda (pos) - (fill-region-as-paragraph pos (point) justify) - (goto-char pos)) - ;; Find the list of ending positions for line breaks - ;; in the current paragraph. Add paragraph - ;; beginning to include first slice. - (nreverse - (cons beg - (org-element-map - (org-element--parse-objects - beg end nil (org-element-restriction 'paragraph)) - 'line-break - (lambda (lb) (org-element-property :end lb))))))) + (goto-char beg) + (let ((cuts (list beg))) + (while (re-search-forward "\\\\\\\\[ \t]*\n" end t) + (when (eq 'line-break + (org-element-type + (save-excursion (backward-char) + (org-element-context)))) + (push (point) cuts))) + (dolist (c (delq end cuts)) + (fill-region-as-paragraph c end justify) + (setq end c)))) t))) ;; Contents of `comment-block' type elements should be ;; filled as plain text, but only if point is within block @@ -22564,6 +23365,130 @@ non-nil." (insert-before-markers-and-inherit fill-prefix)) +;;; Fixed Width Areas + +(defun org-toggle-fixed-width () + "Toggle fixed-width markup. + +Add or remove fixed-width markup on current line, whenever it +makes sense. Return an error otherwise. + +If a region is active and if it contains only fixed-width areas +or blank lines, remove all fixed-width markup in it. If the +region contains anything else, convert all non-fixed-width lines +to fixed-width ones. + +Blank lines at the end of the region are ignored unless the +region only contains such lines." + (interactive) + (if (not (org-region-active-p)) + ;; No region: + ;; + ;; Remove fixed width marker only in a fixed-with element. + ;; + ;; Add fixed width maker in paragraphs, in blank lines after + ;; elements or at the beginning of a headline or an inlinetask, + ;; and before any one-line elements (e.g., a clock). + (progn + (beginning-of-line) + (let* ((element (org-element-at-point)) + (type (org-element-type element))) + (cond + ((and (eq type 'fixed-width) + (looking-at "[ \t]*\\(:\\(?: \\|$\\)\\)")) + (replace-match + "" nil nil nil (if (= (line-end-position) (match-end 0)) 0 1))) + ((and (memq type '(babel-call clock comment diary-sexp headline + horizontal-rule keyword paragraph + planning)) + (<= (org-element-property :post-affiliated element) (point))) + (skip-chars-forward " \t") + (insert ": ")) + ((and (looking-at-p "[ \t]*$") + (or (eq type 'inlinetask) + (save-excursion + (skip-chars-forward " \r\t\n") + (<= (org-element-property :end element) (point))))) + (delete-region (point) (line-end-position)) + (org-indent-line) + (insert ": ")) + (t (user-error "Cannot insert a fixed-width line here"))))) + ;; Region active. + (let* ((begin (save-excursion + (goto-char (region-beginning)) + (line-beginning-position))) + (end (copy-marker + (save-excursion + (goto-char (region-end)) + (unless (eolp) (beginning-of-line)) + (if (save-excursion (re-search-backward "\\S-" begin t)) + (progn (skip-chars-backward " \r\t\n") (point)) + (point))))) + (all-fixed-width-p + (catch 'not-all-p + (save-excursion + (goto-char begin) + (skip-chars-forward " \r\t\n") + (when (eobp) (throw 'not-all-p nil)) + (while (< (point) end) + (let ((element (org-element-at-point))) + (if (eq (org-element-type element) 'fixed-width) + (goto-char (org-element-property :end element)) + (throw 'not-all-p nil)))) + t)))) + (if all-fixed-width-p + (save-excursion + (goto-char begin) + (while (< (point) end) + (when (looking-at "[ \t]*\\(:\\(?: \\|$\\)\\)") + (replace-match + "" nil nil nil + (if (= (line-end-position) (match-end 0)) 0 1))) + (forward-line))) + (let ((min-ind (point-max))) + ;; Find minimum indentation across all lines. + (save-excursion + (goto-char begin) + (if (not (save-excursion (re-search-forward "\\S-" end t))) + (setq min-ind 0) + (catch 'zerop + (while (< (point) end) + (unless (looking-at-p "[ \t]*$") + (let ((ind (org-get-indentation))) + (setq min-ind (min min-ind ind)) + (when (zerop ind) (throw 'zerop t)))) + (forward-line))))) + ;; Loop over all lines and add fixed-width markup everywhere + ;; but in fixed-width lines. + (save-excursion + (goto-char begin) + (while (< (point) end) + (cond + ((org-at-heading-p) + (insert ": ") + (forward-line) + (while (and (< (point) end) (looking-at-p "[ \t]*$")) + (insert ":") + (forward-line))) + ((looking-at-p "[ \t]*:\\( \\|$\\)") + (let* ((element (org-element-at-point)) + (element-end (org-element-property :end element))) + (if (eq (org-element-type element) 'fixed-width) + (progn (goto-char element-end) + (skip-chars-backward " \r\t\n") + (forward-line)) + (let ((limit (min end element-end))) + (while (< (point) limit) + (org-move-to-column min-ind t) + (insert ": ") + (forward-line)))))) + (t + (org-move-to-column min-ind t) + (insert ": ") + (forward-line))))))) + (set-marker end nil)))) + + ;;; Comments ;; Org comments syntax is quite complex. It requires the entire line @@ -22584,87 +23509,139 @@ non-nil." (defun org-setup-comments-handling () (interactive) - (org-set-local 'comment-use-syntax nil) - (org-set-local 'comment-start "# ") - (org-set-local 'comment-start-skip "^\\s-*#\\(?: \\|$\\)") - (org-set-local 'comment-insert-comment-function 'org-insert-comment) - (org-set-local 'comment-region-function 'org-comment-or-uncomment-region) - (org-set-local 'uncomment-region-function 'org-comment-or-uncomment-region)) + (setq-local comment-use-syntax nil) + (setq-local comment-start "# ") + (setq-local comment-start-skip "^\\s-*#\\(?: \\|$\\)") + (setq-local comment-insert-comment-function 'org-insert-comment) + (setq-local comment-region-function 'org-comment-or-uncomment-region) + (setq-local uncomment-region-function 'org-comment-or-uncomment-region)) (defun org-insert-comment () "Insert an empty comment above current line. -If the line is empty, insert comment at its beginning." - (beginning-of-line) - (if (looking-at "\\s-*$") (replace-match "") (open-line 1)) - (org-indent-line) - (insert "# ")) +If the line is empty, insert comment at its beginning. When +point is within a source block, comment according to the related +major mode." + (if (let ((element (org-element-at-point))) + (and (eq (org-element-type element) 'src-block) + (< (save-excursion + (goto-char (org-element-property :post-affiliated element)) + (line-end-position)) + (point)) + (> (save-excursion + (goto-char (org-element-property :end element)) + (skip-chars-backward " \r\t\n") + (line-beginning-position)) + (point)))) + (org-babel-do-in-edit-buffer (call-interactively 'comment-dwim)) + (beginning-of-line) + (if (looking-at "\\s-*$") (delete-region (point) (point-at-eol)) + (open-line 1)) + (org-indent-line) + (insert "# "))) (defvar comment-empty-lines) ; From newcomment.el. (defun org-comment-or-uncomment-region (beg end &rest _) "Comment or uncomment each non-blank line in the region. Uncomment each non-blank line between BEG and END if it only -contains commented lines. Otherwise, comment them." - (save-restriction - ;; Restrict region - (narrow-to-region (save-excursion (goto-char beg) - (skip-chars-forward " \r\t\n" end) - (line-beginning-position)) - (save-excursion (goto-char end) - (skip-chars-backward " \r\t\n" beg) - (line-end-position))) - (let ((uncommentp - ;; UNCOMMENTP is non-nil when every non blank line between - ;; BEG and END is a comment. - (save-excursion - (goto-char (point-min)) - (while (and (not (eobp)) - (let ((element (org-element-at-point))) - (and (eq (org-element-type element) 'comment) - (goto-char (min (point-max) - (org-element-property - :end element))))))) - (eobp)))) - (if uncommentp - ;; Only blank lines and comments in region: uncomment it. - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (when (looking-at "[ \t]*\\(#\\(?: \\|$\\)\\)") - (replace-match "" nil nil nil 1)) - (forward-line))) - ;; Comment each line in region. - (let ((min-indent (point-max))) - ;; First find the minimum indentation across all lines. - (save-excursion - (goto-char (point-min)) - (while (and (not (eobp)) (not (zerop min-indent))) - (unless (looking-at "[ \t]*$") - (setq min-indent (min min-indent (current-indentation)))) - (forward-line))) - ;; Then loop over all lines. - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (unless (and (not comment-empty-lines) (looking-at "[ \t]*$")) - ;; Don't get fooled by invisible text (e.g. link path) - ;; when moving to column MIN-INDENT. - (let ((buffer-invisibility-spec nil)) - (org-move-to-column min-indent t)) - (insert comment-start)) - (forward-line)))))))) +contains commented lines. Otherwise, comment them. If region is +strictly within a source block, use appropriate comment syntax." + (if (let ((element (org-element-at-point))) + (and (eq (org-element-type element) 'src-block) + (< (save-excursion + (goto-char (org-element-property :post-affiliated element)) + (line-end-position)) + beg) + (>= (save-excursion + (goto-char (org-element-property :end element)) + (skip-chars-backward " \r\t\n") + (line-beginning-position)) + end))) + ;; Translate region boundaries for the Org buffer to the source + ;; buffer. + (let ((offset (- end beg))) + (save-excursion + (goto-char beg) + (org-babel-do-in-edit-buffer + (comment-or-uncomment-region (point) (+ offset (point)))))) + (save-restriction + ;; Restrict region + (narrow-to-region (save-excursion (goto-char beg) + (skip-chars-forward " \r\t\n" end) + (line-beginning-position)) + (save-excursion (goto-char end) + (skip-chars-backward " \r\t\n" beg) + (line-end-position))) + (let ((uncommentp + ;; UNCOMMENTP is non-nil when every non blank line between + ;; BEG and END is a comment. + (save-excursion + (goto-char (point-min)) + (while (and (not (eobp)) + (let ((element (org-element-at-point))) + (and (eq (org-element-type element) 'comment) + (goto-char (min (point-max) + (org-element-property + :end element))))))) + (eobp)))) + (if uncommentp + ;; Only blank lines and comments in region: uncomment it. + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at "[ \t]*\\(#\\(?: \\|$\\)\\)") + (replace-match "" nil nil nil 1)) + (forward-line))) + ;; Comment each line in region. + (let ((min-indent (point-max))) + ;; First find the minimum indentation across all lines. + (save-excursion + (goto-char (point-min)) + (while (and (not (eobp)) (not (zerop min-indent))) + (unless (looking-at "[ \t]*$") + (setq min-indent (min min-indent (current-indentation)))) + (forward-line))) + ;; Then loop over all lines. + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (unless (and (not comment-empty-lines) (looking-at "[ \t]*$")) + ;; Don't get fooled by invisible text (e.g. link path) + ;; when moving to column MIN-INDENT. + (let ((buffer-invisibility-spec nil)) + (org-move-to-column min-indent t)) + (insert comment-start)) + (forward-line))))))))) + +(defun org-comment-dwim (_arg) + "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))) -;;; Planning +;;; Timestamps API ;; This section contains tools to operate on 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." + (apply #'encode-time + (cons 0 + (mapcar + (lambda (prop) (or (org-element-property prop timestamp) 0)) + (if end '(:minute-end :hour-end :day-end :month-end :year-end) + '(:minute-start :hour-start :day-start :month-start + :year-start)))))) + (defun org-timestamp-has-time-p (timestamp) "Non-nil when TIMESTAMP has a time specified." (org-element-property :hour-start timestamp)) -(defun org-timestamp-format (timestamp format &optional end zone) - "Format a TIMESTAMP element into a string. +(defun org-timestamp-format (timestamp format &optional end utc) + "Format a TIMESTAMP object into a string. FORMAT is a format specifier to be passed to `format-time-string'. @@ -22672,33 +23649,22 @@ 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. -The optional ZONE is omitted or nil for Emacs local time, t for -Universal Time, `wall' for system wall clock time, or a string as -in the TZ environment variable. It can also be a list (as from -`current-time-zone') or an integer (as from `decode-time') -applied without consideration for daylight saving time." +When optional argument UTC is non-nil, time will be expressed as +Universal Time." (format-time-string - format - (apply 'encode-time - (cons 0 - (mapcar - (lambda (prop) (or (org-element-property prop timestamp) 0)) - (if end '(:minute-end :hour-end :day-end :month-end :year-end) - '(:minute-start :hour-start :day-start :month-start - :year-start))))) - zone)) + format (org-timestamp--to-internal-time timestamp end) + (and utc t))) (defun org-timestamp-split-range (timestamp &optional end) - "Extract a timestamp object from a date or time range. + "Extract a TIMESTAMP object from a date or time range. -TIMESTAMP is a timestamp object. END, when non-nil, means extract -the end of the range. Otherwise, extract its start. +END, when non-nil, means extract the end of the range. +Otherwise, extract its start. -Return a new timestamp object sharing the same parent as -TIMESTAMP." +Return a new timestamp object." (let ((type (org-element-property :type timestamp))) (if (memq type '(active inactive diary)) timestamp - (let ((split-ts (list 'timestamp (copy-sequence (nth 1 timestamp))))) + (let ((split-ts (org-element-copy timestamp))) ;; Set new type. (org-element-put-property split-ts :type (if (eq type 'active-range) 'active 'inactive)) @@ -22712,91 +23678,43 @@ TIMESTAMP." (dolist (p-cell p-alist) (org-element-put-property split-ts - (funcall (if end 'car 'cdr) p-cell) + (funcall (if end #'car #'cdr) p-cell) (org-element-property - (funcall (if end 'cdr 'car) p-cell) split-ts))) + (funcall (if end #'cdr #'car) p-cell) split-ts))) ;; Eventually refresh `:raw-value'. (org-element-put-property split-ts :raw-value nil) (org-element-put-property split-ts :raw-value (org-element-interpret-data split-ts))))))) (defun org-timestamp-translate (timestamp &optional boundary) - "Apply `org-translate-time' on a TIMESTAMP object. + "Translate TIMESTAMP object to custom format. + +Format string is defined in `org-time-stamp-custom-formats', +which see. + When optional argument BOUNDARY is non-nil, it is either the symbol `start' or `end'. In this case, only translate the starting or ending part of TIMESTAMP if it is a date or time -range. Otherwise, translate both parts." - (if (and (not boundary) - (memq (org-element-property :type timestamp) - '(active-range inactive-range))) - (concat - (org-translate-time - (org-element-property :raw-value - (org-timestamp-split-range timestamp))) - "--" - (org-translate-time - (org-element-property :raw-value - (org-timestamp-split-range timestamp t)))) - (org-translate-time - (org-element-property - :raw-value - (if (not boundary) timestamp - (org-timestamp-split-range timestamp (eq boundary 'end))))))) +range. Otherwise, translate both parts. +Return timestamp as-is if `org-display-custom-times' is nil or if +it has a `diary' type." + (let ((type (org-element-property :type timestamp))) + (if (or (not org-display-custom-times) (eq type 'diary)) + (org-element-interpret-data timestamp) + (let ((fmt (funcall (if (org-timestamp-has-time-p timestamp) #'cdr #'car) + org-time-stamp-custom-formats))) + (if (and (not boundary) (memq type '(active-range inactive-range))) + (concat (org-timestamp-format timestamp fmt) + "--" + (org-timestamp-format timestamp fmt t)) + (org-timestamp-format timestamp fmt (eq boundary 'end))))))) -;;; Other stuff. -(defun org-toggle-fixed-width-section (arg) - "Toggle the fixed-width export. -If there is no active region, the QUOTE keyword at the current headline is -inserted or removed. When present, it causes the text between this headline -and the next to be exported as fixed-width text, and unmodified. -If there is an active region, this command adds or removes a colon as the -first character of this line. If the first character of a line is a colon, -this line is also exported in fixed-width font." - (interactive "P") - (let* ((cc 0) - (regionp (org-region-active-p)) - (beg (if regionp (region-beginning) (point))) - (end (if regionp (region-end))) - (nlines (or arg (if (and beg end) (count-lines beg end) 1))) - (case-fold-search nil) - (re "[ \t]*\\(:\\(?: \\|$\\)\\)") - off) - (if regionp - (save-excursion - (goto-char beg) - (setq cc (current-column)) - (beginning-of-line 1) - (setq off (looking-at re)) - (while (> nlines 0) - (setq nlines (1- nlines)) - (beginning-of-line 1) - (cond - (arg - (org-move-to-column cc t) - (insert ": \n") - (forward-line -1)) - ((and off (looking-at re)) - (replace-match "" t t nil 1)) - ((not off) (org-move-to-column cc t) (insert ": "))) - (forward-line 1))) - (save-excursion - (org-back-to-heading) - (cond - ((looking-at (format org-heading-keyword-regexp-format - org-quote-string)) - (goto-char (match-end 1)) - (looking-at (concat " +" org-quote-string)) - (replace-match "" t t) - (when (eolp) (insert " "))) - ((looking-at org-outline-regexp) - (goto-char (match-end 0)) - (insert org-quote-string " "))))))) +;;; Other stuff. (defvar reftex-docstruct-symbol) -(defvar reftex-cite-format) (defvar org--rds) (defun org-reftex-citation () @@ -22814,131 +23732,137 @@ Export of such citations to both LaTeX and HTML is handled by the contributed package ox-bibtex by Taru Karttunen." (interactive) (let ((reftex-docstruct-symbol 'org--rds) - (reftex-cite-format "\\cite{%l}") org--rds bib) - (save-excursion - (save-restriction - (widen) - (let ((case-fold-search t) - (re "^#\\+bibliography:[ \t]+\\([^ \t\n]+\\)")) - (if (not (save-excursion - (or (re-search-forward re nil t) - (re-search-backward re nil t)))) - (error "No bibliography defined in file") - (setq bib (concat (match-string 1) ".bib") - org--rds (list (list 'bib bib))))))) + (org-with-wide-buffer + (let ((case-fold-search t) + (re "^[ \t]*#\\+BIBLIOGRAPHY:[ \t]+\\([^ \t\n]+\\)")) + (if (not (save-excursion + (or (re-search-forward re nil t) + (re-search-backward re nil t)))) + (user-error "No bibliography defined in file") + (setq bib (concat (match-string 1) ".bib") + org--rds (list (list 'bib bib)))))) (call-interactively 'reftex-citation))) ;;;; Functions extending outline functionality -(defun org-beginning-of-line (&optional arg) - "Go to the beginning of the current line. If that is invisible, continue -to a visible line beginning. This makes the function of C-a more intuitive. -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." - (interactive "P") - (let ((pos (point)) - (special (if (consp org-special-ctrl-a/e) - (car org-special-ctrl-a/e) - org-special-ctrl-a/e)) - deactivate-mark refpos) - (if (org-bound-and-true-p visual-line-mode) - (beginning-of-visual-line 1) - (beginning-of-line 1)) - (if (and arg (fboundp 'move-beginning-of-line)) - (call-interactively 'move-beginning-of-line) - (if (bobp) - nil - (backward-char 1) - (if (org-truely-invisible-p) - (while (and (not (bobp)) (org-truely-invisible-p)) - (backward-char 1) - (beginning-of-line 1)) - (forward-char 1)))) - (when special - (cond - ((and (looking-at org-complex-heading-regexp) - (= (char-after (match-end 1)) ?\ )) - (setq refpos (min (1+ (or (match-end 3) (match-end 2) (match-end 1))) - (point-at-eol))) - (goto-char - (if (eq special t) - (cond ((> pos refpos) refpos) - ((= pos (point)) refpos) - (t (point))) - (cond ((> pos (point)) (point)) - ((not (eq last-command this-command)) (point)) - (t refpos))))) - ((org-at-item-p) - ;; Being at an item and not looking at an the item means point - ;; was previously moved to beginning of a visual line, which - ;; doesn't contain the item. Therefore, do nothing special, - ;; just stay here. - (when (looking-at org-list-full-item-re) - ;; Set special position at first white space character after - ;; bullet, and check-box, if any. - (let ((after-bullet - (let ((box (match-end 3))) - (if (not box) (match-end 1) - (let ((after (char-after box))) - (if (and after (= after ? )) (1+ box) box)))))) - ;; Special case: Move point to special position when - ;; currently after it or at beginning of line. - (if (eq special t) - (when (or (> pos after-bullet) (= (point) pos)) - (goto-char after-bullet)) - ;; Reversed case: Move point to special position when - ;; point was already at beginning of line and command is - ;; repeated. - (when (and (= (point) pos) (eq last-command this-command)) - (goto-char after-bullet)))))))) - (org-no-warnings - (and (featurep 'xemacs) (setq zmacs-region-stays t)))) - (setq disable-point-adjustment - (or (not (invisible-p (point))) - (not (invisible-p (max (point-min) (1- (point)))))))) - -(defun org-end-of-line (&optional arg) - "Go to the end of the line. +(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." - (interactive "P") - (let ((special (if (consp org-special-ctrl-a/e) (cdr org-special-ctrl-a/e) - org-special-ctrl-a/e)) - (move-fun (cond ((org-bound-and-true-p visual-line-mode) - 'end-of-visual-line) - ((fboundp 'move-end-of-line) 'move-end-of-line) - (t 'end-of-line))) +the cursor is already beyond the end of the headline. + +With argument N not nil or 1, move forward N - 1 lines first." + (interactive "^p") + (let ((origin (point)) + (special (pcase org-special-ctrl-a/e + (`(,C-a . ,_) C-a) (_ org-special-ctrl-a/e))) deactivate-mark) - (if (or (not special) arg) (call-interactively move-fun) - (let* ((element (save-excursion (beginning-of-line) - (org-element-at-point))) - (type (org-element-type element))) - (cond - ((memq type '(headline inlinetask)) - (let ((pos (point))) - (beginning-of-line 1) - (if (looking-at (org-re ".*?\\(?:\\([ \t]*\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\)?$")) - (if (eq special t) - (if (or (< pos (match-beginning 1)) (= pos (match-end 0))) - (goto-char (match-beginning 1)) - (goto-char (match-end 0))) - (if (or (< pos (match-end 0)) - (not (eq this-command last-command))) - (goto-char (match-end 0)) - (goto-char (match-beginning 1)))) - (call-interactively move-fun)))) - ((org-element-property :hiddenp element) - ;; If element is hidden, `move-end-of-line' would put point - ;; after it. Use `end-of-line' to stay on current line. - (call-interactively 'end-of-line)) - (t (call-interactively move-fun))))) - (org-no-warnings (and (featurep 'xemacs) (setq zmacs-region-stays t)))) - (setq disable-point-adjustment - (or (not (invisible-p (point))) - (not (invisible-p (max (point-min) (1- (point)))))))) + ;; First move to a visible line. + (if (bound-and-true-p visual-line-mode) + (beginning-of-visual-line n) + (move-beginning-of-line n) + ;; `move-beginning-of-line' may leave point after invisible + ;; characters if line starts with such of these (e.g., with + ;; a link at column 0). Really move to the beginning of the + ;; current visible line. + (beginning-of-line)) + (cond + ;; No special behavior. Point is already at the beginning of + ;; a line, logical or visual. + ((not special)) + ;; `beginning-of-visual-line' left point before logical beginning + ;; of line: point is at the beginning of a visual line. Bail + ;; out. + ((and (bound-and-true-p visual-line-mode) (not (bolp)))) + ((let ((case-fold-search nil)) (looking-at org-complex-heading-regexp)) + ;; At a headline, special position is before the title, but + ;; after any TODO keyword or priority cookie. + (let ((refpos (min (1+ (or (match-end 3) (match-end 2) (match-end 1))) + (line-end-position))) + (bol (point))) + (if (eq special 'reversed) + (when (and (= origin bol) (eq last-command this-command)) + (goto-char refpos)) + (when (or (> origin refpos) (= origin bol)) + (goto-char refpos))))) + ((and (looking-at org-list-full-item-re) + (memq (org-element-type (save-match-data (org-element-at-point))) + '(item plain-list))) + ;; Set special position at first white space character after + ;; bullet, and check-box, if any. + (let ((after-bullet + (let ((box (match-end 3))) + (cond ((not box) (match-end 1)) + ((eq (char-after box) ?\s) (1+ box)) + (t box))))) + (if (eq special 'reversed) + (when (and (= (point) origin) (eq last-command this-command)) + (goto-char after-bullet)) + (when (or (> origin after-bullet) (= (point) origin)) + (goto-char after-bullet))))) + ;; No special context. Point is already at beginning of line. + (t nil)))) + +(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. + +With argument N not nil or 1, move forward N - 1 lines first." + (interactive "^p") + (let ((origin (point)) + (special (pcase org-special-ctrl-a/e + (`(,_ . ,C-e) C-e) (_ org-special-ctrl-a/e))) + deactivate-mark) + ;; First move to a visible line. + (if (bound-and-true-p visual-line-mode) + (beginning-of-visual-line n) + (move-beginning-of-line n)) + (cond + ;; At a headline, with tags. + ((and special + (save-excursion + (beginning-of-line) + (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp))) + (match-end 5)) + (let ((tags (save-excursion + (goto-char (match-beginning 5)) + (skip-chars-backward " \t") + (point))) + (visual-end (and (bound-and-true-p visual-line-mode) + (save-excursion + (end-of-visual-line) + (point))))) + ;; If `end-of-visual-line' brings us before end of line or + ;; even tags, i.e., the headline spans over multiple visual + ;; lines, move there. + (cond ((and visual-end + (< visual-end tags) + (<= origin visual-end)) + (goto-char visual-end)) + ((eq special 'reversed) + (if (and (= origin (line-end-position)) + (eq this-command last-command)) + (goto-char tags) + (end-of-line))) + (t + (if (or (< origin tags) (= origin (line-end-position))) + (goto-char tags) + (end-of-line)))))) + ((bound-and-true-p visual-line-mode) + (let ((bol (line-beginning-position))) + (end-of-visual-line) + ;; If `end-of-visual-line' gets us past the ellipsis at the + ;; end of a line, backtrack and use `end-of-line' instead. + (when (/= bol (line-beginning-position)) + (goto-char bol) + (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) @@ -22948,18 +23872,43 @@ the cursor is already beyond the end of the headline." This will call `backward-sentence' or `org-table-beginning-of-field', depending on context." (interactive) - (cond - ((org-at-table-p) (call-interactively 'org-table-beginning-of-field)) - (t (call-interactively 'backward-sentence)))) + (let* ((element (org-element-at-point)) + (contents-begin (org-element-property :contents-begin element)) + (table (org-element-lineage element '(table) t))) + (if (and table + (> (point) contents-begin) + (<= (point) (org-element-property :contents-end table))) + (call-interactively #'org-table-beginning-of-field) + (save-restriction + (when (and contents-begin + (< (point-min) contents-begin) + (> (point) contents-begin)) + (narrow-to-region contents-begin + (org-element-property :contents-end element))) + (call-interactively #'backward-sentence))))) (defun org-forward-sentence (&optional _arg) "Go to end of sentence, or end of table field. This will call `forward-sentence' or `org-table-end-of-field', depending on context." (interactive) - (cond - ((org-at-table-p) (call-interactively 'org-table-end-of-field)) - (t (call-interactively 'forward-sentence)))) + (let* ((element (org-element-at-point)) + (contents-end (org-element-property :contents-end element)) + (table (org-element-lineage element '(table) t))) + (if (and table + (>= (point) (org-element-property :contents-begin table)) + (< (point) contents-end)) + (call-interactively #'org-table-end-of-field) + (save-restriction + (when (and contents-end + (> (point-max) contents-end) + ;; Skip blank lines between elements. + (< (org-element-property :end element) + (save-excursion (goto-char contents-end) + (skip-chars-forward " \r\t\n")))) + (narrow-to-region (org-element-property :contents-begin element) + contents-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) @@ -22971,14 +23920,14 @@ depending on context." ((or (not org-special-ctrl-k) (bolp) (not (org-at-heading-p))) - (if (and (get-char-property (min (point-max) (point-at-eol)) 'invisible) - org-ctrl-k-protect-subtree) - (if (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"))) + (when (and (get-char-property (min (point-max) (point-at-eol)) '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")) (call-interactively - (if (org-bound-and-true-p visual-line-mode) 'kill-visual-line 'kill-line))) - ((looking-at (org-re ".*?\\S-\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)[ \t]*$")) + (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))))) @@ -22991,24 +23940,25 @@ This command will look at the current kill and check if is a single subtree, or a series of subtrees[1]. If it passes the test, and if the cursor is at the beginning of a line or after the stars of a currently empty headline, then the yank is handled specially. How exactly depends -on the value of the following variables, both set by default. +on the value of the following variables. -org-yank-folded-subtrees - When set, the subtree(s) will be folded after insertion, but only - if doing so would now swallow text after the yanked text. +`org-yank-folded-subtrees' + By default, this variable is non-nil, which results in + subtree(s) being folded after insertion, except if doing so + would swallow text after the yanked text. -org-yank-adjusted-subtrees - When set, the subtree will be promoted or demoted in order to - fit into the local outline tree structure, which means that the level - will be adjusted so that it becomes the smaller one of the two - *visible* surrounding headings. +`org-yank-adjusted-subtrees' + When non-nil (the default value is nil), the subtree will be + promoted or demoted in order to fit into the local outline tree + structure, which means that the level will be adjusted so that it + becomes the smaller one of the two *visible* surrounding headings. Any prefix to this command will cause `yank' to be called directly with -no special treatment. In particular, a simple \\[universal-argument] prefix \ +no special treatment. In particular, a simple `\\[universal-argument]' prefix \ will just plainly yank the text as it is. -[1] The test checks if the first non-white line is a heading +\[1] The test checks if the first non-white line is a heading and if there are no other headings with fewer stars." (interactive "P") (org-yank-generic 'yank arg)) @@ -23051,7 +24001,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)) - (hide-subtree) + (outline-hide-subtree) (org-cycle-show-empty-lines 'folded) (condition-case nil (outline-forward-same-level 1) @@ -23082,11 +24032,9 @@ interactive command with similar behavior." (setq level (org-outline-level))) (goto-char end) (skip-chars-forward " \t\r\n\v\f") - (if (or (eobp) - (and (bolp) (looking-at org-outline-regexp) - (<= (org-outline-level) level))) - nil ; Nothing would be swallowed - t))))) ; something would swallow + (not (or (eobp) + (and (bolp) (looking-at-p org-outline-regexp) + (<= (org-outline-level) level)))))))) (define-key org-mode-map "\C-y" 'org-yank) @@ -23094,17 +24042,18 @@ interactive command with similar behavior." "Check if point is at a character currently not visible. This version does not only check the character property, but also `visible-mode'." - ;; Early versions of noutline don't have `outline-invisible-p'. - (if (org-bound-and-true-p visible-mode) - nil - (outline-invisible-p))) + (unless (bound-and-true-p visible-mode) + (org-invisible-p))) (defun org-invisible-p2 () - "Check if point is at a character currently not visible." + "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 - (if (and (eolp) (not (bobp))) (backward-char 1)) - ;; Early versions of noutline don't have `outline-invisible-p'. - (outline-invisible-p))) + (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." @@ -23121,14 +24070,28 @@ This version does not only check the character property, but also (defun org-at-heading-p (&optional ignored) (outline-on-heading-p t)) -;; Compatibility alias with Org versions < 7.8.03 -(defalias 'org-on-heading-p 'org-at-heading-p) + +(defun org-in-commented-heading-p (&optional no-inheritance) + "Non-nil if point is under a commented heading. +This function also checks ancestors of the current headline, +unless optional argument NO-INHERITANCE is non-nil." + (cond + ((org-before-first-heading-p) nil) + ((let ((headline (nth 4 (org-heading-components)))) + (and headline + (let ((case-fold-search nil)) + (string-match-p (concat "^" org-comment-string "\\(?: \\|$\\)") + headline))))) + (no-inheritance nil) + (t + (save-excursion (and (org-up-heading-safe) (org-in-commented-heading-p)))))) (defun org-at-comment-p nil - "Is cursor in a line starting with a # character?" + "Is cursor in a commented line?" (save-excursion - (beginning-of-line) - (looking-at "^#"))) + (save-match-data + (beginning-of-line) + (looking-at "^[ \t]*# ")))) (defun org-at-drawer-p nil "Is cursor at a drawer keyword?" @@ -23146,13 +24109,13 @@ This version does not only check the character property, but also "If point is at the end of an empty headline, return t, else nil. If the heading only contains a TODO keyword, it is still still considered empty." - (and (looking-at "[ \t]*$") - (when org-todo-line-regexp + (let ((case-fold-search nil)) + (and (looking-at "[ \t]*$") + org-todo-line-regexp (save-excursion - (beginning-of-line 1) - (let ((case-fold-search nil)) - (looking-at org-todo-line-regexp) - (string= (match-string 3) "")))))) + (beginning-of-line) + (looking-at org-todo-line-regexp) + (string= (match-string 3) ""))))) (defun org-at-heading-or-item-p () (or (org-at-heading-p) (org-at-item-p))) @@ -23167,9 +24130,7 @@ empty." "Move to the heading line of which the present line is a subheading. This function considers both visible and invisible heading lines. With argument, move up ARG levels." - (if (fboundp 'outline-up-heading-all) - (outline-up-heading-all arg) ; emacs 21 version of outline.el - (outline-up-heading arg t))) ; emacs 22 version of outline.el + (outline-up-heading arg t)) (defun org-up-heading-safe () "Move to the heading line of which the present line is a subheading. @@ -23179,14 +24140,11 @@ headline found, or nil if no higher level is found. Also, this function will be a lot faster than `outline-up-heading', because it relies on stars being the outline starters. This can really make a significant difference in outlines with very many siblings." - (let (start-level re) - (org-back-to-heading t) - (setq start-level (funcall outline-level)) - (if (equal start-level 1) - nil - (setq re (concat "^\\*\\{1," (number-to-string (1- start-level)) "\\} ")) - (if (re-search-backward re nil t) - (funcall outline-level))))) + (when (ignore-errors (org-back-to-heading t)) + (let ((level-up (1- (funcall outline-level)))) + (and (> level-up 0) + (re-search-backward (format "^\\*\\{1,%d\\} " level-up) nil t) + (funcall outline-level))))) (defun org-first-sibling-p () "Is this heading the first child of its parents?" @@ -23211,7 +24169,7 @@ move point." (pos (point)) (re org-outline-regexp-bol) level l) - (when (condition-case nil (org-back-to-heading t) (error nil)) + (when (ignore-errors (org-back-to-heading t)) (setq level (funcall outline-level)) (catch 'exit (or previous (forward-char 1)) @@ -23235,7 +24193,7 @@ move point." Return t when a child was found. Otherwise don't move point and return nil." (let (level (pos (point)) (re org-outline-regexp-bol)) - (when (condition-case nil (org-back-to-heading t) (error nil)) + (when (ignore-errors (org-back-to-heading t)) (setq level (outline-level)) (forward-char 1) (if (and (re-search-forward re nil t) (> (outline-level) level)) @@ -23271,8 +24229,7 @@ This is like outline-next-sibling, but invisible headings are ok." (outline-next-heading) (while (and (not (eobp)) (> (funcall outline-level) level)) (outline-next-heading)) - (if (or (eobp) (< (funcall outline-level) level)) - nil + (unless (or (eobp) (< (funcall outline-level) level)) (point)))) (defun org-get-last-sibling () @@ -23285,8 +24242,7 @@ If there is no such heading, return nil." (while (and (> (funcall outline-level) level) (not (bobp))) (outline-previous-heading)) - (if (< (funcall outline-level) level) - nil + (unless (< (funcall outline-level) level) (point))))) (defun org-end-of-subtree (&optional invisible-ok to-heading) @@ -23302,7 +24258,7 @@ If there is no such heading, return nil." (let ((first t) (level (funcall outline-level))) (if (and (derived-mode-p 'org-mode) (< level 1000)) - ;; A true heading (not a plain list item), in Org-mode + ;; A true heading (not a plain list item), in Org ;; This means we can easily find the end by looking ;; only for the right number of stars. Using a regexp to do ;; this is so much faster than using a Lisp loop. @@ -23315,33 +24271,36 @@ If there is no such heading, return nil." (setq first nil) (outline-next-heading))) (unless to-heading - (if (memq (preceding-char) '(?\n ?\^M)) - (progn - ;; Go to end of line before heading - (forward-char -1) - (if (memq (preceding-char) '(?\n ?\^M)) - ;; leave blank line before heading - (forward-char -1)))))) + (when (memq (preceding-char) '(?\n ?\^M)) + ;; Go to end of line before heading + (forward-char -1) + (when (memq (preceding-char) '(?\n ?\^M)) + ;; leave blank line before heading + (forward-char -1))))) (point)) -(defun org-end-of-meta-data-and-drawers () - "Jump to the first text after meta data and drawers in the current entry. -This will move over empty lines, lines with planning time stamps, -clocking lines, and drawers." +(defun org-end-of-meta-data (&optional full) + "Skip planning line and properties drawer in current entry. +When optional argument FULL is non-nil, also skip empty lines, +clocking lines and regular drawers at the beginning of the +entry." (org-back-to-heading t) - (let ((end (save-excursion (outline-next-heading) (point))) - (re (concat "\\(" org-drawer-regexp "\\)" - "\\|" "[ \t]*" org-keyword-time-regexp))) - (forward-line 1) - (while (re-search-forward re end t) - (if (not (match-end 1)) - ;; empty or planning line - (forward-line 1) - ;; a drawer, find the end - (re-search-forward "^[ \t]*:END:" end 'move) - (forward-line 1))) - (and (re-search-forward "[^\n]" nil t) (backward-char 1)) - (point))) + (forward-line) + (when (looking-at-p org-planning-line-re) (forward-line)) + (when (looking-at org-property-drawer-re) + (goto-char (match-end 0)) + (forward-line)) + (when (and full (not (org-at-heading-p))) + (catch 'exit + (let ((end (save-excursion (outline-next-heading) (point))) + (re (concat "[ \t]*$" "\\|" org-clock-line-re))) + (while (not (eobp)) + (cond ((looking-at-p org-drawer-regexp) + (if (re-search-forward "^[ \t]*:END:[ \t]*$" end t) + (forward-line) + (throw 'exit t))) + ((looking-at-p re) (forward-line)) + (t (throw 'exit t)))))))) (defun org-forward-heading-same-level (arg &optional invisible-ok) "Move forward to the ARG'th subheading at same level as this one. @@ -23349,32 +24308,27 @@ Stop at the first and last subheadings of a superior heading. Normally this only looks at visible headings, but when INVISIBLE-OK is non-nil it will also look at invisible ones." (interactive "p") - (if (not (ignore-errors (org-back-to-heading invisible-ok))) - (if (and arg (< arg 0)) - (goto-char (point-min)) - (outline-next-heading)) - (org-at-heading-p) - (let ((level (- (match-end 0) (match-beginning 0) 1)) - (f (if (and arg (< arg 0)) - 're-search-backward - 're-search-forward)) - (count (if arg (abs arg) 1)) - (result (point))) - (while (and (prog1 (> count 0) - (forward-char (if (and arg (< arg 0)) -1 1))) - (funcall f org-outline-regexp-bol nil 'move)) - (let ((l (- (match-end 0) (match-beginning 0) 1))) - (cond ((< l level) (setq count 0)) - ((and (= l level) - (or invisible-ok - (progn - (goto-char (line-beginning-position)) - (not (outline-invisible-p))))) - (setq count (1- count)) - (when (eq l level) - (setq result (point))))))) - (goto-char result)) - (beginning-of-line 1))) + (let ((backward? (and arg (< arg 0)))) + (if (org-before-first-heading-p) + (if backward? (goto-char (point-min)) (outline-next-heading)) + (org-back-to-heading invisible-ok) + (unless backward? (end-of-line)) ;do not match current headline + (let ((level (- (match-end 0) (match-beginning 0) 1)) + (f (if backward? #'re-search-backward #'re-search-forward)) + (count (if arg (abs arg) 1)) + (result (point))) + (while (and (> count 0) + (funcall f org-outline-regexp-bol nil 'move)) + (let ((l (- (match-end 0) (match-beginning 0) 1))) + (cond ((< l level) (setq count 0)) + ((and (= l level) + (or invisible-ok + (not (org-invisible-p + (line-beginning-position))))) + (cl-decf count) + (when (= l level) (setq result (point))))))) + (goto-char result)) + (beginning-of-line)))) (defun org-backward-heading-same-level (arg &optional invisible-ok) "Move backward to the ARG'th subheading at same level as this one. @@ -23382,20 +24336,64 @@ Stop at the first and last subheadings of a superior heading." (interactive "p") (org-forward-heading-same-level (if arg (- arg) -1) invisible-ok)) +(defun org-next-visible-heading (arg) + "Move to the next visible heading. + +This function wraps `outline-next-visible-heading' with +`org-with-limited-levels' in order to skip over inline tasks and +respect customization of `org-odd-levels-only'." + (interactive "p") + (org-with-limited-levels + (outline-next-visible-heading arg))) + +(defun org-previous-visible-heading (arg) + "Move to the previous visible heading. + +This function wraps `outline-previous-visible-heading' with +`org-with-limited-levels' in order to skip over inline tasks and +respect customization of `org-odd-levels-only'." + (interactive "p") + (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 source blocks. + +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." + +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 org-block-regexp)) - (re-search-fn (or (and backward 're-search-backward) - 're-search-forward))) - (if (looking-at re) (forward-char 1)) - (condition-case nil - (funcall re-search-fn re nil nil arg) - (error (error "No %s code blocks" (if backward "previous" "further" )))) - (goto-char (match-beginning 0)) (org-show-context))) + (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. @@ -23434,7 +24432,7 @@ item, etc. It also provides some special moves for convenience: (skip-chars-forward " \r\t\n") (or (eobp) (beginning-of-line))) ;; On affiliated keywords, move to element's beginning. - ((and post-affiliated (< (point) post-affiliated)) + ((< (point) post-affiliated) (goto-char post-affiliated)) ;; At a table row, move to the end of the table. Similarly, ;; at a node property, move to the end of the property @@ -23461,8 +24459,8 @@ item, etc. It also provides some special moves for convenience: ;; With no contents, just skip element. ((not contents-begin) (goto-char end)) ;; If contents are invisible, skip the element altogether. - ((outline-invisible-p (line-end-position)) - (case type + ((org-invisible-p (line-end-position)) + (cl-case type (headline (org-with-limited-levels (outline-next-visible-heading 1))) ;; At a plain list, make sure we move to the next item @@ -23473,7 +24471,7 @@ item, etc. It also provides some special moves for convenience: ((>= (point) contents-end) (goto-char end)) ((>= (point) contents-begin) ;; This can only happen on paragraphs and plain lists. - (case type + (cl-case type (paragraph (goto-char end)) ;; At a plain list, try to move to second element in ;; first item, if possible. @@ -23513,7 +24511,7 @@ convenience: ((= (point) begin) (backward-char) (org-backward-paragraph)) - ((and post-affiliated (<= (point) post-affiliated)) (goto-char begin)) + ((<= (point) post-affiliated) (goto-char begin)) ((memq type '(node-property table-row)) (goto-char (org-element-property :post-affiliated (org-element-property :parent element)))) @@ -23548,7 +24546,7 @@ convenience: (org-backward-paragraph)) (t (goto-char (or post-affiliated begin)))) ;; Ensure we never leave point invisible. - (when (outline-invisible-p (point)) (beginning-of-visual-line)))) + (when (org-invisible-p (point)) (beginning-of-visual-line)))) (defun org-forward-element () "Move forward by one element. @@ -23587,18 +24585,21 @@ Move to the previous element at the same level, when possible." (progn (goto-char origin) (user-error "Cannot move further up")))))) (t - (let* ((trail (org-element-at-point 'keep-trail)) - (elem (car trail)) - (prev-elem (nth 1 trail)) + (let* ((elem (org-element-at-point)) (beg (org-element-property :begin elem))) (cond ;; Move to beginning of current element if point isn't ;; there already. ((null beg) (message "No element at point")) ((/= (point) beg) (goto-char beg)) - (prev-elem (goto-char (org-element-property :begin prev-elem))) - ((org-before-first-heading-p) (goto-char (point-min))) - (t (org-back-to-heading))))))) + (t (goto-char beg) + (skip-chars-backward " \r\t\n") + (unless (bobp) + (let ((prev (org-element-at-point))) + (goto-char (org-element-property :begin prev)) + (while (and (setq prev (org-element-property :parent prev)) + (<= (org-element-property :end prev) beg)) + (goto-char (org-element-property :begin prev))))))))))) (defun org-up-element () "Move to upper element." @@ -23612,7 +24613,6 @@ Move to the previous element at the same level, when possible." (user-error "No surrounding element") (org-with-limited-levels (org-back-to-heading))))))) -(defvar org-element-greater-elements) (defun org-down-element () "Move to inner element." (interactive) @@ -23623,7 +24623,7 @@ Move to the previous element at the same level, when possible." (forward-char)) ((memq (org-element-type element) org-element-greater-elements) ;; If contents are hidden, first disclose them. - (when (org-element-property :hiddenp element) (org-cycle)) + (when (org-invisible-p (line-end-position)) (org-cycle)) (goto-char (or (org-element-property :contents-begin element) (user-error "No content for this element")))) (t (user-error "No inner element"))))) @@ -23631,24 +24631,41 @@ Move to the previous element at the same level, when possible." (defun org-drag-element-backward () "Move backward element at point." (interactive) - (if (org-with-limited-levels (org-at-heading-p)) (org-move-subtree-up) - (let* ((trail (org-element-at-point 'keep-trail)) - (elem (car trail)) - (prev-elem (nth 1 trail))) - ;; Error out if no previous element or previous element is - ;; a parent of the current one. - (if (or (not prev-elem) (org-element-nested-p elem prev-elem)) - (user-error "Cannot drag element backward") - (let ((pos (point))) - (org-element-swap-A-B prev-elem elem) - (goto-char (+ (org-element-property :begin prev-elem) - (- pos (org-element-property :begin elem))))))))) + (let ((elem (or (org-element-at-point) + (user-error "No element at point")))) + (if (eq (org-element-type elem) 'headline) + ;; Preserve point when moving a whole tree, even if point was + ;; on blank lines below the headline. + (let ((offset (skip-chars-backward " \t\n"))) + (unwind-protect (org-move-subtree-up) + (forward-char (- offset)))) + (let ((prev-elem + (save-excursion + (goto-char (org-element-property :begin elem)) + (skip-chars-backward " \r\t\n") + (unless (bobp) + (let* ((beg (org-element-property :begin elem)) + (prev (org-element-at-point)) + (up prev)) + (while (and (setq up (org-element-property :parent up)) + (<= (org-element-property :end up) beg)) + (setq prev up)) + prev))))) + ;; Error out if no previous element or previous element is + ;; a parent of the current one. + (if (or (not prev-elem) (org-element-nested-p elem prev-elem)) + (user-error "Cannot drag element backward") + (let ((pos (point))) + (org-element-swap-A-B prev-elem elem) + (goto-char (+ (org-element-property :begin prev-elem) + (- pos (org-element-property :begin elem)))))))))) (defun org-drag-element-forward () "Move forward element at point." (interactive) (let* ((pos (point)) - (elem (org-element-at-point))) + (elem (or (org-element-at-point) + (user-error "No element at point")))) (when (= (point-max) (org-element-property :end elem)) (user-error "Cannot drag element forward")) (goto-char (org-element-property :end elem)) @@ -23681,7 +24698,7 @@ Move to the previous element at the same level, when possible." (defun org-drag-line-forward (arg) "Drag the line at point ARG lines forward." (interactive "p") - (dotimes (n (abs arg)) + (dotimes (_ (abs arg)) (let ((c (current-column))) (if (< 0 arg) (progn @@ -23705,7 +24722,7 @@ mode) if the mark is active, it marks the next element after the ones already marked." (interactive) (let (deactivate-mark) - (if (and (org-called-interactively-p 'any) + (if (and (called-interactively-p 'any) (or (and (eq last-command this-command) (mark t)) (and transient-mark-mode mark-active))) (set-mark @@ -23751,13 +24768,10 @@ modified." (interactive) (unless (eq major-mode 'org-mode) (user-error "Cannot un-indent a buffer not in Org mode")) - (let* ((parse-tree (org-element-parse-buffer 'greater-element)) - unindent-tree ; For byte-compiler. - (unindent-tree - (function - (lambda (contents) - (mapc - (lambda (element) + (letrec ((parse-tree (org-element-parse-buffer 'greater-element)) + (unindent-tree + (lambda (contents) + (dolist (element (reverse contents)) (if (memq (org-element-type element) '(headline section)) (funcall unindent-tree (org-element-contents element)) (save-excursion @@ -23765,10 +24779,49 @@ modified." (narrow-to-region (org-element-property :begin element) (org-element-property :end element)) - (org-do-remove-indentation))))) - (reverse contents)))))) + (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) @@ -23783,58 +24836,33 @@ modified." Show the heading too, if it is currently invisible." (interactive) (save-excursion - (condition-case nil - (progn - (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)) - (error nil)))) + (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." - (concat - "^#\\+\\(" - (mapconcat 'regexp-quote kwds "\\|") - (if extra (concat "\\|" extra)) - "\\):[ \t]*\\(.*\\)")) - -;; Make isearch reveal the necessary context -(defun org-isearch-end () - "Reveal context after isearch exits." - (when isearch-success ; only if search was successful - (if (featurep 'xemacs) - ;; Under XEmacs, the hook is run in the correct place, - ;; we directly show the context. - (org-show-context 'isearch) - ;; In Emacs the hook runs *before* restoring the overlays. - ;; So we have to use a one-time post-command-hook to do this. - ;; (Emacs 22 has a special variable, see function `org-mode') - (unless (and (boundp 'isearch-mode-end-hook-quit) - isearch-mode-end-hook-quit) - ;; Only when the isearch was not quitted. - (org-add-hook 'post-command-hook 'org-isearch-post-command - 'append 'local))))) - -(defun org-isearch-post-command () - "Remove self from hook, and show context." - (remove-hook 'post-command-hook 'org-isearch-post-command 'local) - (org-show-context 'isearch)) - + "Make a regular expression for keyword lines. +KWDS is a list of keywords, as strings. Optional argument EXTRA, +when non-nil, is a regexp matching keywords names." + (concat "^[ \t]*#\\+\\(" + (regexp-opt kwds) + (and extra (concat (and kwds "\\|") extra)) + "\\):[ \t]*\\(.*\\)")) ;;;; Integration with and fixes for other packages ;;; Imenu support -(defvar org-imenu-markers nil +(defvar-local org-imenu-markers nil "All markers currently used by Imenu.") -(make-variable-buffer-local 'org-imenu-markers) (defun org-imenu-new-marker (&optional pos) "Return a new marker for use by Imenu, and remember the marker." @@ -23845,50 +24873,48 @@ Show the heading too, if it is currently invisible." (defun org-imenu-get-tree () "Produce the index for Imenu." - (mapc (lambda (x) (move-marker x nil)) org-imenu-markers) + (dolist (x org-imenu-markers) (move-marker x nil)) (setq org-imenu-markers nil) - (let* ((n org-imenu-depth) + (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) - (save-excursion - (save-restriction - (widen) - (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 (org-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)) - (loop for i from (1+ level) to n do (aset subs i nil))) - (setq last-level level))))) + (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 () - (if (derived-mode-p 'org-mode) - (org-show-context 'org-goto)))))) + (when (derived-mode-p 'org-mode) + (org-show-context 'org-goto)))))) -(defun org-link-display-format (link) - "Replace a link with its the description. +(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 - (if (string-match org-bracket-link-analytic-regexp link) - (replace-match (if (match-end 5) - (match-string 5 link) - (concat (match-string 1 link) - (match-string 3 link))) - nil t link) - link))) + (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." @@ -23909,11 +24935,11 @@ If there is no description, use the link target." 'face 'org-agenda-restriction-lock) (overlay-put org-speedbar-restriction-lock-overlay 'help-echo "Agendas are currently limited to this item.") -(org-detach-overlay org-speedbar-restriction-lock-overlay) +(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]." +To get rid of the restriction, use `\\[org-agenda-remove-restriction-lock]'." (interactive) (require 'org-agenda) (let (p m tp np dir txt) @@ -23937,9 +24963,9 @@ To get rid of the restriction, use \\[org-agenda-remove-restriction-lock]." (let ((default-directory dir)) (expand-file-name txt))) (unless (derived-mode-p 'org-mode) - (user-error "Cannot restrict to non-Org-mode file")) + (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's agenda"))) + (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) @@ -23959,34 +24985,98 @@ To get rid of the restriction, use \\[org-agenda-remove-restriction-lock]." ;;; Fixes and Hacks for problems with other packages -;; Make flyspell not check words in links, to not mess up our keymap -(defvar org-element-affiliated-keywords) ; From org-element.el -(defvar org-element-block-name-alist) ; From org-element.el +(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 () - "Don't let flyspell put overlays at active buttons, or on - {todo,all-time,additional-option-like}-keywords." - (require 'org-element) ; For `org-element-affiliated-keywords' - (let ((pos (max (1- (point)) (point-min))) - (word (thing-at-point 'word))) - (and (not (get-text-property pos 'keymap)) - (not (get-text-property pos 'org-no-flyspell)) - (not (member word org-todo-keywords-1)) - (not (member word org-all-time-keywords)) - (not (member word org-options-keywords)) - (not (member word (mapcar 'car org-startup-options))) - (not (member-ignore-case word org-element-affiliated-keywords)) - (not (member-ignore-case word (org-get-export-keywords))) - (not (member-ignore-case - word (mapcar 'car org-element-block-name-alist))) - (not (member-ignore-case word '("BEGIN" "END" "ATTR"))) - (not (org-in-src-block-p))))) + "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 (org-bound-and-true-p flyspell-mode) + (and (bound-and-true-p flyspell-mode) (fboundp 'flyspell-delete-region-overlays) - (flyspell-delete-region-overlays beg end)) - (add-text-properties beg end '(org-no-flyspell t))) + (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" @@ -24008,17 +25098,38 @@ To get rid of the restriction, use \\[org-agenda-remove-restriction-lock]." (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." - (if (derived-mode-p 'org-mode) - (org-show-context)))) + (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 (outline-invisible-p) + (or (org-invisible-p) (save-excursion (goto-char (max (point-min) (1- (point)))) - (outline-invisible-p))) + (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" |