tec/org-mode
tec
/
org-mode
forked from mirrors/org-mode
1
0
Fork 0
Code Pull Requests Releases Activity

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.
This commit is contained in:
Ihor Radchenko 2021-10-16 23:50:21 +08:00
parent 60c927f8b8
commit e70a8aac59
No known key found for this signature in database
GPG Key ID: 6470762A7DA11D8B
5 changed files with 141 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
lisp/org-agenda.el
View File

@ -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. `let' to scope it dynamically into the agenda-constructing command.
A good way to set it is through options in `org-agenda-custom-commands'.") 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. "Throw to `:skip' in places that should be skipped.
Also moves point to the end of the skipped region, so that search can 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) (let ((p (point-at-bol)) to)
(when (or (when (or
(save-excursion (goto-char p) (looking-at comment-start-skip)) (save-excursion (goto-char p) (looking-at comment-start-skip))
(and org-agenda-skip-archived-trees (not org-agenda-archives-mode) (and org-agenda-skip-archived-trees (not org-agenda-archives-mode)
(or (and (get-text-property p :org-archived) (or (and (save-match-data (org-in-archived-heading-p nil element))
(org-end-of-subtree t)) (org-end-of-subtree t element))
(and (member org-archive-tag org-file-tags) (and (member org-archive-tag org-file-tags)
(goto-char (point-max))))) (goto-char (point-max)))))
(and org-agenda-skip-comment-trees (and org-agenda-skip-comment-trees
(get-text-property p :org-comment) (org-in-commented-heading-p nil element)
(org-end-of-subtree t)) (org-end-of-subtree t element))
(and (setq to (or (org-agenda-skip-eval org-agenda-skip-function-global) (and (setq to (or (org-agenda-skip-eval org-agenda-skip-function-global)
(org-agenda-skip-eval org-agenda-skip-function))) (org-agenda-skip-eval org-agenda-skip-function)))
(goto-char to)) (goto-char to))
@ -5550,7 +5552,8 @@ and the timestamp type relevant for the sorting strategy in
(t org-not-done-regexp)))) (t org-not-done-regexp))))
marker priority category level tags todo-state marker priority category level tags todo-state
ts-date ts-date-type ts-date-pair 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)) (goto-char (point-min))
(while (re-search-forward regexp nil t) (while (re-search-forward regexp nil t)
(catch :skip (catch :skip
@ -5569,6 +5572,8 @@ and the timestamp type relevant for the sorting strategy in
(goto-char (match-beginning 2)) (goto-char (match-beginning 2))
(setq marker (org-agenda-new-marker (match-beginning 0)) (setq marker (org-agenda-new-marker (match-beginning 0))
category (org-get-category) 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-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair) ts-date (car ts-date-pair)
ts-date-type (cdr 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)) ? ) level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t) txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt))) 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-add-props txt props
'org-marker marker 'org-hd-marker marker 'org-marker marker 'org-hd-marker marker
'priority priority 'priority priority
'effort effort 'effort-minutes effort-minutes
'level level 'level level
'ts-date ts-date 'ts-date ts-date
'type (concat "todo" ts-date-type) 'todo-state todo-state) 'type (concat "todo" ts-date-type) 'todo-state todo-state)
@ -5789,6 +5796,8 @@ displayed in agenda view."
(assq (point) deadline-position-alist)) (assq (point) deadline-position-alist))
(throw :skip nil)) (throw :skip nil))
(let* ((category (org-get-category pos)) (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 (inherited-tags
(or (eq org-agenda-show-inherited-tags 'always) (or (eq org-agenda-show-inherited-tags 'always)
(and (consp org-agenda-show-inherited-tags) (and (consp org-agenda-show-inherited-tags)
@ -5816,6 +5825,7 @@ displayed in agenda view."
'org-hd-marker (org-agenda-new-marker) 'org-hd-marker (org-agenda-new-marker)
'date date 'date date
'level level 'level level
'effort effort 'effort-minutes effort-minutes
'ts-date (if repeat (org-agenda--timestamp-to-absolute repeat) 'ts-date (if repeat (org-agenda--timestamp-to-absolute repeat)
current) current)
'todo-state todo-state 'todo-state todo-state
@ -5839,7 +5849,8 @@ displayed in agenda view."
;; FIXME: Is this `entry' binding intended to be dynamic, ;; FIXME: Is this `entry' binding intended to be dynamic,
;; so as to "hide" any current binding for it? ;; so as to "hide" any current binding for it?
marker category extra level ee txt tags entry 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)) (goto-char (point-min))
(while (re-search-forward regexp nil t) (while (re-search-forward regexp nil t)
(catch :skip (catch :skip
@ -5857,6 +5868,8 @@ displayed in agenda view."
(setq marker (org-agenda-new-marker beg) (setq marker (org-agenda-new-marker beg)
level (make-string (org-reduced-level (org-outline-level)) ? ) level (make-string (org-reduced-level (org-outline-level)) ? )
category (org-get-category beg) category (org-get-category beg)
effort (save-match-data (or (get-text-property (point) 'effort)
(org-entry-get (point) org-effort-property)))
inherited-tags inherited-tags
(or (eq org-agenda-show-inherited-tags 'always) (or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags) (and (listp org-agenda-show-inherited-tags)
@ -5868,6 +5881,7 @@ displayed in agenda view."
todo-state (org-get-todo-state) todo-state (org-get-todo-state)
warntime (get-text-property (point) 'org-appt-warntime) warntime (get-text-property (point) 'org-appt-warntime)
extra nil) extra nil)
(setq effort-minutes (when effort (save-match-data (org-duration-to-minutes effort))))
(dolist (r (if (stringp result) (dolist (r (if (stringp result)
(list result) (list result)
@ -5882,6 +5896,7 @@ displayed in agenda view."
(setq txt (org-agenda-format-item extra txt level category tags 'time)) (setq txt (org-agenda-format-item extra txt level category tags 'time))
(org-add-props txt props 'org-marker marker (org-add-props txt props 'org-marker marker
'date date 'todo-state todo-state 'date date 'todo-state todo-state
'effort effort 'effort-minutes effort-minutes
'level level 'type "sexp" 'warntime warntime) 'level level 'type "sexp" 'warntime warntime)
(push txt ee))))) (push txt ee)))))
(nreverse ee))) (nreverse ee)))
@ -5972,7 +5987,8 @@ then those holidays will be skipped."
1 11)))) 1 11))))
(org-agenda-search-headline-for-time nil) (org-agenda-search-headline-for-time nil)
marker hdmarker priority category level tags closedp type 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)) (goto-char (point-min))
(while (re-search-forward regexp nil t) (while (re-search-forward regexp nil t)
(catch :skip (catch :skip
@ -5983,7 +5999,10 @@ then those holidays will be skipped."
clockp (not (or closedp statep)) clockp (not (or closedp statep))
state (and statep (match-string 2)) state (and statep (match-string 2))
category (org-get-category (match-beginning 0)) 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) (when (string-match "\\]" timestr)
;; substring should only run to end of time stamp ;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0)) (setq rest (substring timestr (match-end 0))
@ -6038,6 +6057,7 @@ then those holidays will be skipped."
(org-add-props txt props (org-add-props txt props
'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done 'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done
'priority priority 'level level 'priority priority 'level level
'effort effort 'effort-minutes effort-minutes
'type type 'date date 'type type 'date date
'undone-face 'org-warning 'done-face 'org-agenda-done) 'undone-face 'org-warning 'done-face 'org-agenda-done)
(push txt ee)) (push txt ee))
@ -6262,6 +6282,9 @@ specification like [h]h:mm."
(re-search-backward "^\\*+[ \t]+" nil t) (re-search-backward "^\\*+[ \t]+" nil t)
(goto-char (match-end 0)) (goto-char (match-end 0))
(let* ((category (org-get-category)) (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)) (level (make-string (org-reduced-level (org-outline-level))
?\s)) ?\s))
(head (buffer-substring (point) (line-end-position))) (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)) 'org-hd-marker (org-agenda-new-marker (line-beginning-position))
'warntime warntime 'warntime warntime
'level level 'level level
'effort effort 'effort-minutes effort-minutes
'ts-date deadline 'ts-date deadline
'priority 'priority
;; Adjust priority to today reminders about deadlines. ;; 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) (re-search-backward "^\\*+[ \t]+" nil t)
(goto-char (match-end 0)) (goto-char (match-end 0))
(let* ((category (org-get-category)) (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 (inherited-tags
(or (eq org-agenda-show-inherited-tags 'always) (or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags) (and (listp org-agenda-show-inherited-tags)
@ -6521,6 +6548,7 @@ scheduled items with an hour specification like [h]h:mm."
'ts-date schedule 'ts-date schedule
'warntime warntime 'warntime warntime
'level level 'level level
'effort effort 'effort-minutes effort-minutes
'priority (if habitp (org-habit-get-priority habitp) 'priority (if habitp (org-habit-get-priority habitp)
(+ 99 diff (org-get-priority item))) (+ 99 diff (org-get-priority item)))
'org-habit-p habitp 'org-habit-p habitp
@ -6542,7 +6570,8 @@ scheduled items with an hour specification like [h]h:mm."
(regexp org-tr-regexp) (regexp org-tr-regexp)
(d0 (calendar-absolute-from-gregorian date)) (d0 (calendar-absolute-from-gregorian date))
marker hdmarker ee txt d1 d2 s1 s2 category 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)) (goto-char (point-min))
(while (re-search-forward regexp nil t) (while (re-search-forward regexp nil t)
(catch :skip (catch :skip
@ -6582,6 +6611,9 @@ scheduled items with an hour specification like [h]h:mm."
(throw :skip t)) (throw :skip t))
(setq marker (org-agenda-new-marker (point)) (setq marker (org-agenda-new-marker (point))
category (org-get-category)) 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)) (if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil) (throw :skip nil)
(goto-char (match-beginning 0)) (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 'org-marker marker 'org-hd-marker hdmarker
'type "block" 'date date 'type "block" 'date date
'level level 'level level
'effort effort 'effort-minutes effort-minutes
'todo-state todo-state 'todo-state todo-state
'priority (org-get-priority txt)) 'priority (org-get-priority txt))
(push txt ee)))) (push txt ee))))

4
lisp/org-clock.el
View File

@ -35,6 +35,7 @@
(declare-function notifications-notify "notifications" (&rest params)) (declare-function notifications-notify "notifications" (&rest params))
(declare-function org-element-property "org-element" (property element)) (declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (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-at-task-p "org-inlinetask" ())
(declare-function org-inlinetask-goto-beginning "org-inlinetask" ()) (declare-function org-inlinetask-goto-beginning "org-inlinetask" ())
(declare-function org-inlinetask-goto-end "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." the default behavior."
(interactive "P") (interactive "P")
(setq org-clock-notification-was-shown nil) (setq org-clock-notification-was-shown nil)
(org-refresh-effort-properties) (unless (org-element--cache-active-p)
(org-refresh-effort-properties))
(catch 'abort (catch 'abort
(let ((interrupting (and (not org-clock-resolving-clocks-due-to-idleness) (let ((interrupting (and (not org-clock-resolving-clocks-due-to-idleness)
(org-clocking-p))) (org-clocking-p)))

49
lisp/org-duration.el
View File

@ -284,30 +284,31 @@ translated into 0.0.
Return value as a float. Raise an error if duration format is Return value as a float. Raise an error if duration format is
not recognized." not recognized."
(cond (save-match-data
((equal duration "") 0.0) (cond
((numberp duration) (float duration)) ((equal duration "") 0.0)
((string-match-p org-duration--h:mm-re duration) ((numberp duration) (float duration))
(pcase-let ((`(,hours ,minutes ,seconds) ((string-match-p org-duration--h:mm-re duration)
(mapcar #'string-to-number (split-string duration ":")))) (pcase-let ((`(,hours ,minutes ,seconds)
(+ (/ (or seconds 0) 60.0) minutes (* 60 hours)))) (mapcar #'string-to-number (split-string duration ":"))))
((string-match-p org-duration--full-re duration) (+ (/ (or seconds 0) 60.0) minutes (* 60 hours))))
(let ((minutes 0) ((string-match-p org-duration--full-re duration)
(s 0)) (let ((minutes 0)
(while (string-match org-duration--unit-re duration s) (s 0))
(setq s (match-end 0)) (while (string-match org-duration--unit-re duration s)
(let ((value (string-to-number (match-string 1 duration))) (setq s (match-end 0))
(unit (match-string 2 duration))) (let ((value (string-to-number (match-string 1 duration)))
(cl-incf minutes (* value (org-duration--modifier unit canonical))))) (unit (match-string 2 duration)))
(float minutes))) (cl-incf minutes (* value (org-duration--modifier unit canonical)))))
((string-match org-duration--mixed-re duration) (float minutes)))
(let ((units-part (match-string 1 duration)) ((string-match org-duration--mixed-re duration)
(hms-part (match-string 2 duration))) (let ((units-part (match-string 1 duration))
(+ (org-duration-to-minutes units-part) (hms-part (match-string 2 duration)))
(org-duration-to-minutes hms-part)))) (+ (org-duration-to-minutes units-part)
((string-match-p "\\`[0-9]+\\(\\.[0-9]*\\)?\\'" duration) (org-duration-to-minutes hms-part))))
(float (string-to-number duration))) ((string-match-p "\\`[0-9]+\\(\\.[0-9]*\\)?\\'" duration)
(t (error "Invalid duration format: %S" duration)))) (float (string-to-number duration)))
(t (error "Invalid duration format: %S" duration)))))
;;;###autoload ;;;###autoload
(defun org-duration-from-minutes (minutes &optional fmt canonical) (defun org-duration-from-minutes (minutes &optional fmt canonical)

137
lisp/org.el
View File

@ -8565,9 +8565,15 @@ call CMD."
(save-match-data (save-match-data
(when force-refresh (org-refresh-category-properties)) (when force-refresh (org-refresh-category-properties))
(let ((pos (or pos (point)))) (let ((pos (or pos (point))))
(or (get-text-property pos 'org-category) (if (org-element--cache-active-p)
(progn (org-refresh-category-properties) ;; Sync cache.
(get-text-property pos 'org-category)))))) (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 ;;; Refresh properties
@ -8614,57 +8620,59 @@ the whole buffer."
(org-end-of-subtree t t)) (org-end-of-subtree t t))
((outline-next-heading)) ((outline-next-heading))
((point-max)))))) ((point-max))))))
(if (symbolp tprop) (with-silent-modifications
;; TPROP is a text property symbol. (if (symbolp tprop)
(put-text-property start end tprop p) ;; TPROP is a text property symbol.
;; TPROP is an alist with (property . function) elements. (put-text-property start end tprop p)
(pcase-dolist (`(,prop . ,f) tprop) ;; TPROP is an alist with (property . function) elements.
(put-text-property start end prop (funcall f p))))))) (pcase-dolist (`(,prop . ,f) tprop)
(put-text-property start end prop (funcall f p))))))))
(defun org-refresh-category-properties () (defun org-refresh-category-properties ()
"Refresh category text properties in the buffer." "Refresh category text properties in the buffer."
(let ((case-fold-search t) (unless (org-element--cache-active-p)
(inhibit-read-only t) (let ((case-fold-search t)
(default-category (inhibit-read-only t)
(cond ((null org-category) (default-category
(if buffer-file-name (cond ((null org-category)
(file-name-sans-extension (if buffer-file-name
(file-name-nondirectory buffer-file-name)) (file-name-sans-extension
"???")) (file-name-nondirectory buffer-file-name))
((symbolp org-category) (symbol-name org-category)) "???"))
(t org-category)))) ((symbolp org-category) (symbol-name org-category))
(with-silent-modifications (t org-category))))
(org-with-wide-buffer (let ((category (catch 'buffer-category
;; Set buffer-wide property from keyword. Search last #+CATEGORY (org-with-wide-buffer
;; keyword. If none is found, fall-back to `org-category' or (goto-char (point-max))
;; buffer file name, or set it by the document property drawer. (while (re-search-backward "^[ \t]*#\\+CATEGORY:" (point-min) t)
(put-text-property (let ((element (org-element-at-point-no-context)))
(point-min) (point-max) (when (eq (org-element-type element) 'keyword)
'org-category (throw 'buffer-category
(catch 'buffer-category (org-element-property :value element))))))
(goto-char (point-max)) default-category)))
(while (re-search-backward "^[ \t]*#\\+CATEGORY:" (point-min) t) (with-silent-modifications
(let ((element (org-element-at-point))) (org-with-wide-buffer
(when (eq (org-element-type element) 'keyword) ;; Set buffer-wide property from keyword. Search last #+CATEGORY
(throw 'buffer-category ;; keyword. If none is found, fall-back to `org-category' or
(org-element-property :value element))))) ;; buffer file name, or set it by the document property drawer.
default-category)) (put-text-property (point-min) (point-max)
;; Set categories from the document property drawer or 'org-category category)
;; property drawers in the outline. If category is found in ;; Set categories from the document property drawer or
;; the property drawer for the whole buffer that value ;; property drawers in the outline. If category is found in
;; overrides the keyword-based value set above. ;; the property drawer for the whole buffer that value
(goto-char (point-min)) ;; overrides the keyword-based value set above.
(let ((regexp (org-re-property "CATEGORY"))) (goto-char (point-min))
(while (re-search-forward regexp nil t) (let ((regexp (org-re-property "CATEGORY")))
(let ((value (match-string-no-properties 3))) (while (re-search-forward regexp nil t)
(when (org-at-property-p) (let ((value (match-string-no-properties 3)))
(put-text-property (when (org-at-property-p)
(save-excursion (org-back-to-heading-or-point-min t)) (put-text-property
(save-excursion (if (org-before-first-heading-p) (save-excursion (org-back-to-heading-or-point-min t))
(point-max) (save-excursion (if (org-before-first-heading-p)
(org-end-of-subtree t t))) (point-max)
'org-category (org-end-of-subtree t t)))
value))))))))) 'org-category
value)))))))))))
(defun org-refresh-stats-properties () (defun org-refresh-stats-properties ()
"Refresh stats text properties in the buffer." "Refresh stats text properties in the buffer."
@ -11806,7 +11814,7 @@ See also `org-scan-tags'."
(propp (propp
(let* ((gv (pcase (upcase (match-string 5 term)) (let* ((gv (pcase (upcase (match-string 5 term))
("CATEGORY" ("CATEGORY"
'(get-text-property (point) 'org-category)) '(org-get-category (point)))
("TODO" 'todo) ("TODO" 'todo)
(p `(org-cached-entry-get nil ,p)))) (p `(org-cached-entry-get nil ,p))))
(pv (match-string 7 term)) (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) (defun org-agenda-prepare-buffers (files)
"Create buffers for all agenda files, protect archived trees and comments." "Create buffers for all agenda files, protect archived trees and comments."
(interactive) (interactive)
(let ((pa '(:org-archived t)) (let ((inhibit-read-only t)
(pc '(:org-comment t))
(pall '(:org-archived t :org-comment t))
(inhibit-read-only t)
(org-inhibit-startup org-agenda-inhibit-startup) (org-inhibit-startup org-agenda-inhibit-startup)
(rea (org-make-tag-string (list org-archive-tag))) pos)
re pos)
(setq org-tag-alist-for-agenda nil (setq org-tag-alist-for-agenda nil
org-tag-groups-alist-for-agenda nil) org-tag-groups-alist-for-agenda nil)
(save-excursion (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) (or (memq 'stats org-agenda-ignore-properties)
(org-refresh-stats-properties)) (org-refresh-stats-properties))
(or (memq 'effort org-agenda-ignore-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) (or (memq 'appt org-agenda-ignore-properties)
(org-refresh-properties "APPT_WARNTIME" 'org-appt-warntime)) (org-refresh-properties "APPT_WARNTIME" 'org-appt-warntime))
(setq org-todo-keywords-for-agenda (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 (if old
(setcdr old (org-uniquify (append (cdr old) (cdr alist)))) (setcdr old (org-uniquify (append (cdr old) (cdr alist))))
(push alist org-tag-groups-alist-for-agenda))))) (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))))) (goto-char pos)))))
(setq org-todo-keywords-for-agenda (setq org-todo-keywords-for-agenda
(org-uniquify org-todo-keywords-for-agenda)) (org-uniquify org-todo-keywords-for-agenda))

10
testing/lisp/test-org.el
View File

@ -6279,13 +6279,13 @@ Paragraph<point>"
(org-test-with-temp-text (org-test-with-temp-text
":PROPERTIES:\n:CATEGORY: cat1\n:END:" ":PROPERTIES:\n:CATEGORY: cat1\n:END:"
(org-refresh-category-properties) (org-refresh-category-properties)
(get-text-property (point) 'org-category)))) (org-get-category))))
(should (should
(equal "cat1" (equal "cat1"
(org-test-with-temp-text (org-test-with-temp-text
"* H\n:PROPERTIES:\n:CATEGORY: cat1\n:END:" "* H\n:PROPERTIES:\n:CATEGORY: cat1\n:END:"
(org-refresh-category-properties) (org-refresh-category-properties)
(get-text-property (point) 'org-category)))) (org-get-category))))
;; Even though property-inheritance is deactivated, category ;; Even though property-inheritance is deactivated, category
;; property should be inherited. As described in ;; property should be inherited. As described in
;; `org-use-property-inheritance'. ;; `org-use-property-inheritance'.
@ -6296,7 +6296,7 @@ Paragraph<point>"
(org-mode-restart) (org-mode-restart)
(let ((org-use-property-inheritance nil)) (let ((org-use-property-inheritance nil))
(org-refresh-category-properties)) (org-refresh-category-properties))
(get-text-property (point) 'org-category)))) (org-get-category))))
(should (should
(equal "cat1" (equal "cat1"
(org-test-with-temp-text (org-test-with-temp-text
@ -6304,7 +6304,7 @@ Paragraph<point>"
(org-mode-restart) (org-mode-restart)
(let ((org-use-property-inheritance t)) (let ((org-use-property-inheritance t))
(org-refresh-category-properties)) (org-refresh-category-properties))
(get-text-property (point) 'org-category)))) (org-get-category))))
(should (should
(equal "cat2" (equal "cat2"
(org-test-with-temp-text (org-test-with-temp-text
@ -6312,7 +6312,7 @@ Paragraph<point>"
(org-mode-restart) (org-mode-restart)
(let ((org-use-property-inheritance t)) (let ((org-use-property-inheritance t))
(org-refresh-category-properties)) (org-refresh-category-properties))
(get-text-property (point) 'org-category))))) (org-get-category)))))
;;; Refile ;;; Refile