From e70a8aac593c5aae517e6f0b98e6061cefb15a6c Mon Sep 17 00:00:00 2001 From: Ihor Radchenko Date: Sat, 16 Oct 2021 23:50:21 +0800 Subject: [PATCH] Use org-element-cache in place of text property cache in agenda * lisp/org-agenda.el (org-agenda-skip): Use `org-in-archived-heading-p' and `org-in-commented-heading-p' in place of text property cache. (org-agenda-get-todos, org-agenda-get-timestamps, org-agenda-get-sexps, org-agenda-get-progress, org-agenda-get-deadlines, org-agenda-get-scheduled, org-agenda-get-blocks): Do not use text property cache in favour of Org API functions. The API functions use cache now. * lisp/org-clock.el (org-element--cache-active-p): Declare function to suppress compiler warning. (org-clock-in): Do not use text property cache when element cache is active. * lisp/org-duration.el (org-duration-to-minutes): Do not change match data. It is needed to not break agenda---agenda relies on match data not being altered. * lisp/org.el (org-run-like-in-org-mode): Use element cache. (org-refresh-category-properties): Use element cache. (org-make-tags-matcher, org-agenda-prepare-buffers): Do not rely on text property cache. * testing/lisp/test-org.el (test-org/refresh-category-properties): Do not use text property cache. --- lisp/org-agenda.el | 55 ++++++++++++---- lisp/org-clock.el | 4 +- lisp/org-duration.el | 49 +++++++------- lisp/org.el | 137 ++++++++++++++++++--------------------- testing/lisp/test-org.el | 10 +-- 5 files changed, 141 insertions(+), 114 deletions(-) diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el index 5eb896b9a..888bd92f5 100644 --- a/lisp/org-agenda.el +++ b/lisp/org-agenda.el @@ -4162,21 +4162,23 @@ The correct usage for `org-agenda-skip-function' is to bind it with `let' to scope it dynamically into the agenda-constructing command. A good way to set it is through options in `org-agenda-custom-commands'.") -(defun org-agenda-skip () +(defun org-agenda-skip (&optional element) "Throw to `:skip' in places that should be skipped. Also moves point to the end of the skipped region, so that search can -continue from there." +continue from there. + +Optional argument ELEMENT contains element at point." (let ((p (point-at-bol)) to) (when (or (save-excursion (goto-char p) (looking-at comment-start-skip)) (and org-agenda-skip-archived-trees (not org-agenda-archives-mode) - (or (and (get-text-property p :org-archived) - (org-end-of-subtree t)) + (or (and (save-match-data (org-in-archived-heading-p nil element)) + (org-end-of-subtree t element)) (and (member org-archive-tag org-file-tags) (goto-char (point-max))))) (and org-agenda-skip-comment-trees - (get-text-property p :org-comment) - (org-end-of-subtree t)) + (org-in-commented-heading-p nil element) + (org-end-of-subtree t element)) (and (setq to (or (org-agenda-skip-eval org-agenda-skip-function-global) (org-agenda-skip-eval org-agenda-skip-function))) (goto-char to)) @@ -5550,7 +5552,8 @@ and the timestamp type relevant for the sorting strategy in (t org-not-done-regexp)))) marker priority category level tags todo-state ts-date ts-date-type ts-date-pair - ee txt beg end inherited-tags todo-state-end-pos) + ee txt beg end inherited-tags todo-state-end-pos + effort effort-minutes) (goto-char (point-min)) (while (re-search-forward regexp nil t) (catch :skip @@ -5569,6 +5572,8 @@ and the timestamp type relevant for the sorting strategy in (goto-char (match-beginning 2)) (setq marker (org-agenda-new-marker (match-beginning 0)) category (org-get-category) + effort (save-match-data (or (get-text-property (point) 'effort) + (org-entry-get (point) org-effort-property))) ts-date-pair (org-agenda-entry-get-agenda-timestamp (point)) ts-date (car ts-date-pair) ts-date-type (cdr ts-date-pair) @@ -5584,9 +5589,11 @@ and the timestamp type relevant for the sorting strategy in level (make-string (org-reduced-level (org-outline-level)) ? ) txt (org-agenda-format-item "" txt level category tags t) priority (1+ (org-get-priority txt))) + (setq effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))) (org-add-props txt props 'org-marker marker 'org-hd-marker marker 'priority priority + 'effort effort 'effort-minutes effort-minutes 'level level 'ts-date ts-date 'type (concat "todo" ts-date-type) 'todo-state todo-state) @@ -5789,6 +5796,8 @@ displayed in agenda view." (assq (point) deadline-position-alist)) (throw :skip nil)) (let* ((category (org-get-category pos)) + (effort (org-entry-get pos org-effort-property)) + (effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))) (inherited-tags (or (eq org-agenda-show-inherited-tags 'always) (and (consp org-agenda-show-inherited-tags) @@ -5816,6 +5825,7 @@ displayed in agenda view." 'org-hd-marker (org-agenda-new-marker) 'date date 'level level + 'effort effort 'effort-minutes effort-minutes 'ts-date (if repeat (org-agenda--timestamp-to-absolute repeat) current) 'todo-state todo-state @@ -5839,7 +5849,8 @@ displayed in agenda view." ;; FIXME: Is this `entry' binding intended to be dynamic, ;; so as to "hide" any current binding for it? marker category extra level ee txt tags entry - result beg b sexp sexp-entry todo-state warntime inherited-tags) + result beg b sexp sexp-entry todo-state warntime inherited-tags + effort effort-minutes) (goto-char (point-min)) (while (re-search-forward regexp nil t) (catch :skip @@ -5857,6 +5868,8 @@ displayed in agenda view." (setq marker (org-agenda-new-marker beg) level (make-string (org-reduced-level (org-outline-level)) ? ) category (org-get-category beg) + effort (save-match-data (or (get-text-property (point) 'effort) + (org-entry-get (point) org-effort-property))) inherited-tags (or (eq org-agenda-show-inherited-tags 'always) (and (listp org-agenda-show-inherited-tags) @@ -5868,6 +5881,7 @@ displayed in agenda view." todo-state (org-get-todo-state) warntime (get-text-property (point) 'org-appt-warntime) extra nil) + (setq effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))) (dolist (r (if (stringp result) (list result) @@ -5882,6 +5896,7 @@ displayed in agenda view." (setq txt (org-agenda-format-item extra txt level category tags 'time)) (org-add-props txt props 'org-marker marker 'date date 'todo-state todo-state + 'effort effort 'effort-minutes effort-minutes 'level level 'type "sexp" 'warntime warntime) (push txt ee))))) (nreverse ee))) @@ -5972,7 +5987,8 @@ then those holidays will be skipped." 1 11)))) (org-agenda-search-headline-for-time nil) marker hdmarker priority category level tags closedp type - statep clockp state ee txt extra timestr rest clocked inherited-tags) + statep clockp state ee txt extra timestr rest clocked inherited-tags + effort effort-minutes) (goto-char (point-min)) (while (re-search-forward regexp nil t) (catch :skip @@ -5983,7 +5999,10 @@ then those holidays will be skipped." clockp (not (or closedp statep)) state (and statep (match-string 2)) category (org-get-category (match-beginning 0)) - timestr (buffer-substring (match-beginning 0) (point-at-eol))) + timestr (buffer-substring (match-beginning 0) (point-at-eol)) + effort (save-match-data (or (get-text-property (point) 'effort) + (org-entry-get (point) org-effort-property)))) + (setq effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))) (when (string-match "\\]" timestr) ;; substring should only run to end of time stamp (setq rest (substring timestr (match-end 0)) @@ -6038,6 +6057,7 @@ then those holidays will be skipped." (org-add-props txt props 'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done 'priority priority 'level level + 'effort effort 'effort-minutes effort-minutes 'type type 'date date 'undone-face 'org-warning 'done-face 'org-agenda-done) (push txt ee)) @@ -6262,6 +6282,9 @@ specification like [h]h:mm." (re-search-backward "^\\*+[ \t]+" nil t) (goto-char (match-end 0)) (let* ((category (org-get-category)) + (effort (save-match-data (or (get-text-property (point) 'effort) + (org-entry-get (point) org-effort-property)))) + (effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))) (level (make-string (org-reduced-level (org-outline-level)) ?\s)) (head (buffer-substring (point) (line-end-position))) @@ -6302,6 +6325,7 @@ specification like [h]h:mm." 'org-hd-marker (org-agenda-new-marker (line-beginning-position)) 'warntime warntime 'level level + 'effort effort 'effort-minutes effort-minutes 'ts-date deadline 'priority ;; Adjust priority to today reminders about deadlines. @@ -6468,6 +6492,9 @@ scheduled items with an hour specification like [h]h:mm." (re-search-backward "^\\*+[ \t]+" nil t) (goto-char (match-end 0)) (let* ((category (org-get-category)) + (effort (save-match-data (or (get-text-property (point) 'effort) + (org-entry-get (point) org-effort-property)))) + (effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))) (inherited-tags (or (eq org-agenda-show-inherited-tags 'always) (and (listp org-agenda-show-inherited-tags) @@ -6521,6 +6548,7 @@ scheduled items with an hour specification like [h]h:mm." 'ts-date schedule 'warntime warntime 'level level + 'effort effort 'effort-minutes effort-minutes 'priority (if habitp (org-habit-get-priority habitp) (+ 99 diff (org-get-priority item))) 'org-habit-p habitp @@ -6542,7 +6570,8 @@ scheduled items with an hour specification like [h]h:mm." (regexp org-tr-regexp) (d0 (calendar-absolute-from-gregorian date)) marker hdmarker ee txt d1 d2 s1 s2 category - level todo-state tags pos head donep inherited-tags) + level todo-state tags pos head donep inherited-tags + effort effort-minutes) (goto-char (point-min)) (while (re-search-forward regexp nil t) (catch :skip @@ -6582,6 +6611,9 @@ scheduled items with an hour specification like [h]h:mm." (throw :skip t)) (setq marker (org-agenda-new-marker (point)) category (org-get-category)) + (setq effort (save-match-data (or (get-text-property (point) 'effort) + (org-entry-get (point) org-effort-property)))) + (setq effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))) (if (not (re-search-backward org-outline-regexp-bol nil t)) (throw :skip nil) (goto-char (match-beginning 0)) @@ -6628,6 +6660,7 @@ scheduled items with an hour specification like [h]h:mm." 'org-marker marker 'org-hd-marker hdmarker 'type "block" 'date date 'level level + 'effort effort 'effort-minutes effort-minutes 'todo-state todo-state 'priority (org-get-priority txt)) (push txt ee)))) diff --git a/lisp/org-clock.el b/lisp/org-clock.el index 2e9a1c9b2..1ac680ba7 100644 --- a/lisp/org-clock.el +++ b/lisp/org-clock.el @@ -35,6 +35,7 @@ (declare-function notifications-notify "notifications" (&rest params)) (declare-function org-element-property "org-element" (property element)) (declare-function org-element-type "org-element" (element)) +(declare-function org-element--cache-active-p "org-element" ()) (declare-function org-inlinetask-at-task-p "org-inlinetask" ()) (declare-function org-inlinetask-goto-beginning "org-inlinetask" ()) (declare-function org-inlinetask-goto-end "org-inlinetask" ()) @@ -1265,7 +1266,8 @@ time as the start time. See `org-clock-continuously' to make this the default behavior." (interactive "P") (setq org-clock-notification-was-shown nil) - (org-refresh-effort-properties) + (unless (org-element--cache-active-p) + (org-refresh-effort-properties)) (catch 'abort (let ((interrupting (and (not org-clock-resolving-clocks-due-to-idleness) (org-clocking-p))) diff --git a/lisp/org-duration.el b/lisp/org-duration.el index e627d0936..0e38b79c4 100644 --- a/lisp/org-duration.el +++ b/lisp/org-duration.el @@ -284,30 +284,31 @@ translated into 0.0. Return value as a float. Raise an error if duration format is not recognized." - (cond - ((equal duration "") 0.0) - ((numberp duration) (float duration)) - ((string-match-p org-duration--h:mm-re duration) - (pcase-let ((`(,hours ,minutes ,seconds) - (mapcar #'string-to-number (split-string duration ":")))) - (+ (/ (or seconds 0) 60.0) minutes (* 60 hours)))) - ((string-match-p org-duration--full-re duration) - (let ((minutes 0) - (s 0)) - (while (string-match org-duration--unit-re duration s) - (setq s (match-end 0)) - (let ((value (string-to-number (match-string 1 duration))) - (unit (match-string 2 duration))) - (cl-incf minutes (* value (org-duration--modifier unit canonical))))) - (float minutes))) - ((string-match org-duration--mixed-re duration) - (let ((units-part (match-string 1 duration)) - (hms-part (match-string 2 duration))) - (+ (org-duration-to-minutes units-part) - (org-duration-to-minutes hms-part)))) - ((string-match-p "\\`[0-9]+\\(\\.[0-9]*\\)?\\'" duration) - (float (string-to-number duration))) - (t (error "Invalid duration format: %S" duration)))) + (save-match-data + (cond + ((equal duration "") 0.0) + ((numberp duration) (float duration)) + ((string-match-p org-duration--h:mm-re duration) + (pcase-let ((`(,hours ,minutes ,seconds) + (mapcar #'string-to-number (split-string duration ":")))) + (+ (/ (or seconds 0) 60.0) minutes (* 60 hours)))) + ((string-match-p org-duration--full-re duration) + (let ((minutes 0) + (s 0)) + (while (string-match org-duration--unit-re duration s) + (setq s (match-end 0)) + (let ((value (string-to-number (match-string 1 duration))) + (unit (match-string 2 duration))) + (cl-incf minutes (* value (org-duration--modifier unit canonical))))) + (float minutes))) + ((string-match org-duration--mixed-re duration) + (let ((units-part (match-string 1 duration)) + (hms-part (match-string 2 duration))) + (+ (org-duration-to-minutes units-part) + (org-duration-to-minutes hms-part)))) + ((string-match-p "\\`[0-9]+\\(\\.[0-9]*\\)?\\'" duration) + (float (string-to-number duration))) + (t (error "Invalid duration format: %S" duration))))) ;;;###autoload (defun org-duration-from-minutes (minutes &optional fmt canonical) diff --git a/lisp/org.el b/lisp/org.el index a3cb07019..75432775d 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -8565,9 +8565,15 @@ call CMD." (save-match-data (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)))))) + (if (org-element--cache-active-p) + ;; Sync cache. + (org-with-point-at (org-element-property :begin (org-element-at-point pos)) + (or (org-entry-get-with-inheritance "CATEGORY") + "???")) + (or (get-text-property pos 'org-category) + (progn + (org-refresh-category-properties) + (get-text-property pos 'org-category))))))) ;;; Refresh properties @@ -8614,57 +8620,59 @@ the whole buffer." (org-end-of-subtree t t)) ((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))))))) + (with-silent-modifications + (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)))) - (with-silent-modifications - (org-with-wide-buffer - ;; Set buffer-wide property from keyword. Search last #+CATEGORY - ;; keyword. If none is found, fall-back to `org-category' or - ;; buffer file name, or set it by the document property drawer. - (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 categories from the document property drawer or - ;; property drawers in the outline. If category is found in - ;; the property drawer for the whole buffer that value - ;; overrides the keyword-based value set above. - (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-or-point-min t)) - (save-excursion (if (org-before-first-heading-p) - (point-max) - (org-end-of-subtree t t))) - 'org-category - value))))))))) + (unless (org-element--cache-active-p) + (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)))) + (let ((category (catch 'buffer-category + (org-with-wide-buffer + (goto-char (point-max)) + (while (re-search-backward "^[ \t]*#\\+CATEGORY:" (point-min) t) + (let ((element (org-element-at-point-no-context))) + (when (eq (org-element-type element) 'keyword) + (throw 'buffer-category + (org-element-property :value element)))))) + default-category))) + (with-silent-modifications + (org-with-wide-buffer + ;; Set buffer-wide property from keyword. Search last #+CATEGORY + ;; keyword. If none is found, fall-back to `org-category' or + ;; buffer file name, or set it by the document property drawer. + (put-text-property (point-min) (point-max) + 'org-category category) + ;; Set categories from the document property drawer or + ;; property drawers in the outline. If category is found in + ;; the property drawer for the whole buffer that value + ;; overrides the keyword-based value set above. + (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-or-point-min t)) + (save-excursion (if (org-before-first-heading-p) + (point-max) + (org-end-of-subtree t t))) + 'org-category + value))))))))))) (defun org-refresh-stats-properties () "Refresh stats text properties in the buffer." @@ -11806,7 +11814,7 @@ See also `org-scan-tags'." (propp (let* ((gv (pcase (upcase (match-string 5 term)) ("CATEGORY" - '(get-text-property (point) 'org-category)) + '(org-get-category (point))) ("TODO" 'todo) (p `(org-cached-entry-get nil ,p)))) (pv (match-string 7 term)) @@ -15746,13 +15754,9 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (defun org-agenda-prepare-buffers (files) "Create buffers for all agenda files, protect archived trees and comments." (interactive) - (let ((pa '(:org-archived t)) - (pc '(:org-comment t)) - (pall '(:org-archived t :org-comment t)) - (inhibit-read-only t) + (let ((inhibit-read-only t) (org-inhibit-startup org-agenda-inhibit-startup) - (rea (org-make-tag-string (list org-archive-tag))) - re pos) + pos) (setq org-tag-alist-for-agenda nil org-tag-groups-alist-for-agenda nil) (save-excursion @@ -15771,7 +15775,8 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (or (memq 'stats org-agenda-ignore-properties) (org-refresh-stats-properties)) (or (memq 'effort org-agenda-ignore-properties) - (org-refresh-effort-properties)) + (unless (org-element--cache-active-p) + (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 @@ -15792,20 +15797,6 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (if old (setcdr old (org-uniquify (append (cdr old) (cdr alist)))) (push alist org-tag-groups-alist-for-agenda))))) - (with-silent-modifications - (save-excursion - (remove-text-properties (point-min) (point-max) pall) - (when org-agenda-skip-archived-trees - (goto-char (point-min)) - (while (re-search-forward rea nil t) - (when (org-at-heading-p t) - (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) - (goto-char (point-min)) - (setq re (format "^\\*+ .*\\<%s\\>" org-comment-string)) - (while (re-search-forward re nil t) - (when (save-match-data (org-in-commented-heading-p t)) - (add-text-properties - (match-beginning 0) (org-end-of-subtree t) pc))))) (goto-char pos))))) (setq org-todo-keywords-for-agenda (org-uniquify org-todo-keywords-for-agenda)) diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el index 4a4663455..378b35c3d 100644 --- a/testing/lisp/test-org.el +++ b/testing/lisp/test-org.el @@ -6279,13 +6279,13 @@ Paragraph" (org-test-with-temp-text ":PROPERTIES:\n:CATEGORY: cat1\n:END:" (org-refresh-category-properties) - (get-text-property (point) 'org-category)))) + (org-get-category)))) (should (equal "cat1" (org-test-with-temp-text "* H\n:PROPERTIES:\n:CATEGORY: cat1\n:END:" (org-refresh-category-properties) - (get-text-property (point) 'org-category)))) + (org-get-category)))) ;; Even though property-inheritance is deactivated, category ;; property should be inherited. As described in ;; `org-use-property-inheritance'. @@ -6296,7 +6296,7 @@ Paragraph" (org-mode-restart) (let ((org-use-property-inheritance nil)) (org-refresh-category-properties)) - (get-text-property (point) 'org-category)))) + (org-get-category)))) (should (equal "cat1" (org-test-with-temp-text @@ -6304,7 +6304,7 @@ Paragraph" (org-mode-restart) (let ((org-use-property-inheritance t)) (org-refresh-category-properties)) - (get-text-property (point) 'org-category)))) + (org-get-category)))) (should (equal "cat2" (org-test-with-temp-text @@ -6312,7 +6312,7 @@ Paragraph" (org-mode-restart) (let ((org-use-property-inheritance t)) (org-refresh-category-properties)) - (get-text-property (point) 'org-category))))) + (org-get-category))))) ;;; Refile