ndwarshuis
/
org-mode
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

org.el/org-scan-tags: Make use of fast `org-element-cache-map'

This commit is contained in:
Ihor Radchenko 2021-10-17 00:00:01 +08:00
parent 85e0a69567
commit 3c4290e668
No known key found for this signature in database
GPG Key ID: 6470762A7DA11D8B
1 changed files with 190 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

294
lisp/org.el
View File

@ -11533,115 +11533,201 @@ headlines matching this string."
(when (eq action 'sparse-tree) (when (eq action 'sparse-tree)
(org-overview) (org-overview)
(org-remove-occur-highlights)) (org-remove-occur-highlights))
(while (let (case-fold-search) (if (org-element--cache-active-p)
(re-search-forward re nil t)) (let ((fast-re (concat "^"
(setq org-map-continue-from nil) (if start-level
(catch :skip ;; Get the correct level to match
;; Ignore closing parts of inline tasks. (concat "\\*\\{" (number-to-string start-level) "\\} ")
(when (and (fboundp 'org-inlinetask-end-p) (org-inlinetask-end-p)) org-outline-regexp))))
(throw :skip t)) (org-element-cache-map
(setq todo (and (match-end 1) (match-string-no-properties 1))) (lambda (el)
(setq tags (and (match-end 4) (org-trim (match-string-no-properties 4)))) (goto-char (org-element-property :begin el))
(goto-char (setq lspos (match-beginning 0))) (setq todo (org-element-property :todo-keyword el)
(setq level (org-reduced-level (org-outline-level)) level (org-element-property :level el)
category (org-get-category)) category (org-entry-get-with-inheritance "CATEGORY" nil el)
(when (eq action 'agenda) tags-list (org-get-tags el)
(setq ts-date-pair (org-agenda-entry-get-agenda-timestamp (point)) org-scanner-tags tags-list)
ts-date (car ts-date-pair) (when (eq action 'agenda)
ts-date-type (cdr ts-date-pair))) (setq ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
(setq i llast llast level) ts-date (car ts-date-pair)
;; remove tag lists from same and sublevels ts-date-type (cdr ts-date-pair)))
(while (>= i level) (catch :skip
(when (setq entry (assoc i tags-alist)) (when (and
(setq tags-alist (delete entry tags-alist)))
(setq i (1- i)))
;; add the next tags
(when tags
(setq tags (org-split-string tags ":")
tags-alist
(cons (cons level tags) tags-alist)))
;; compile tags for current headline
(setq tags-list
(if org-use-tag-inheritance
(apply 'append (mapcar 'cdr (reverse tags-alist)))
tags)
org-scanner-tags tags-list)
(when org-use-tag-inheritance
(setcdr (car tags-alist)
(mapcar (lambda (x)
(setq x (copy-sequence x))
(org-add-prop-inherited x))
(cdar tags-alist))))
(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.
(setcdr (car tags-alist)
(org-remove-uninherited-tags (cdar tags-alist))))
(when (and
;; eval matcher only when the todo condition is OK ;; eval matcher only when the todo condition is OK
(and (or (not todo-only) (member todo org-todo-keywords-1)) (and (or (not todo-only) (member todo org-todo-keywords-1))
(if (functionp matcher) (if (functionp matcher)
(let ((case-fold-search t) (org-trust-scanner-tags t)) (let ((case-fold-search t) (org-trust-scanner-tags t))
(funcall matcher todo tags-list level)) (funcall matcher todo tags-list level))
matcher)) matcher))
;; Call the skipper, but return t if it does not ;; Call the skipper, but return t if it does not
;; skip, so that the `and' form continues evaluating. ;; skip, so that the `and' form continues evaluating.
(progn (progn
(unless (eq action 'sparse-tree) (org-agenda-skip)) (unless (eq action 'sparse-tree) (org-agenda-skip el))
t) t)
;; Check if timestamps are deselecting this entry ;; Check if timestamps are deselecting this entry
(or (not todo-only) (or (not todo-only)
(and (member todo org-todo-keywords-1) (and (member todo org-todo-keywords-1)
(or (not org-agenda-tags-todo-honor-ignore-options) (or (not org-agenda-tags-todo-honor-ignore-options)
(not (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item)))))) (not (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item))))))
;; select this headline ;; select this headline
(cond (cond
((eq action 'sparse-tree) ((eq action 'sparse-tree)
(and org-highlight-sparse-tree-matches (and org-highlight-sparse-tree-matches
(org-get-heading) (match-end 0) (org-get-heading) (match-end 0)
(org-highlight-new-match (org-highlight-new-match
(match-beginning 1) (match-end 1))) (match-beginning 1) (match-end 1)))
(org-show-context 'tags-tree)) (org-show-context 'tags-tree))
((eq action 'agenda) ((eq action 'agenda)
(setq txt (org-agenda-format-item (setq txt (org-agenda-format-item
"" ""
(concat (concat
(if (eq org-tags-match-list-sublevels 'indented) (if (eq org-tags-match-list-sublevels 'indented)
(make-string (1- level) ?.) "") (make-string (1- level) ?.) "")
(org-get-heading)) (org-get-heading))
(make-string level ?\s) (make-string level ?\s)
category category
tags-list) tags-list)
priority (org-get-priority txt)) priority (org-get-priority txt))
(goto-char lspos) (goto-char (org-element-property :begin el))
(setq marker (org-agenda-new-marker)) (setq marker (org-agenda-new-marker))
(org-add-props txt props (org-add-props txt props
'org-marker marker 'org-hd-marker marker 'org-category category 'org-marker marker 'org-hd-marker marker 'org-category category
'todo-state todo 'todo-state todo
'ts-date ts-date 'ts-date ts-date
'priority priority 'priority priority
'type (concat "tagsmatch" ts-date-type)) 'type (concat "tagsmatch" ts-date-type))
(push txt rtn)) (push txt rtn))
((functionp action) ((functionp action)
(setq org-map-continue-from nil) (setq org-map-continue-from nil)
(save-excursion (save-excursion
(setq rtn1 (funcall action)) (setq rtn1 (funcall action))
(push rtn1 rtn))) (push rtn1 rtn)))
(t (user-error "Invalid action"))) (t (user-error "Invalid action")))
;; if we are to skip sublevels, jump to end of subtree ;; if we are to skip sublevels, jump to end of subtree
(unless org-tags-match-list-sublevels (unless org-tags-match-list-sublevels
(org-end-of-subtree t) (goto-char (1- (org-element-property :end el))))))
(backward-char 1)))) ;; Get the correct position from where to continue
;; Get the correct position from where to continue (when org-map-continue-from
(if org-map-continue-from (goto-char org-map-continue-from))
(goto-char org-map-continue-from) ;; Return nil.
(and (= (point) lspos) (end-of-line 1))))) nil)
:next-re fast-re
:fail-re fast-re
:narrow t))
(while (let (case-fold-search)
(re-search-forward re nil t))
(setq org-map-continue-from nil)
(catch :skip
;; Ignore closing parts of inline tasks.
(when (and (fboundp 'org-inlinetask-end-p) (org-inlinetask-end-p))
(throw :skip t))
(setq todo (and (match-end 1) (match-string-no-properties 1)))
(setq tags (and (match-end 4) (org-trim (match-string-no-properties 4))))
(goto-char (setq lspos (match-beginning 0)))
(setq level (org-reduced-level (org-outline-level))
category (org-get-category))
(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)
(when (setq entry (assoc i tags-alist))
(setq tags-alist (delete entry tags-alist)))
(setq i (1- i)))
;; add the next tags
(when tags
(setq tags (org-split-string tags ":")
tags-alist
(cons (cons level tags) tags-alist)))
;; compile tags for current headline
(setq tags-list
(if org-use-tag-inheritance
(apply 'append (mapcar 'cdr (reverse tags-alist)))
tags)
org-scanner-tags tags-list)
(when org-use-tag-inheritance
(setcdr (car tags-alist)
(mapcar (lambda (x)
(setq x (copy-sequence x))
(org-add-prop-inherited x))
(cdar tags-alist))))
(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.
(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-todo-keywords-1))
(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.
(progn
(unless (eq action 'sparse-tree) (org-agenda-skip))
t)
;; Check if timestamps are deselecting this entry
(or (not todo-only)
(and (member todo org-todo-keywords-1)
(or (not org-agenda-tags-todo-honor-ignore-options)
(not (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item))))))
;; select this headline
(cond
((eq action 'sparse-tree)
(and org-highlight-sparse-tree-matches
(org-get-heading) (match-end 0)
(org-highlight-new-match
(match-beginning 1) (match-end 1)))
(org-show-context 'tags-tree))
((eq action 'agenda)
(setq txt (org-agenda-format-item
""
(concat
(if (eq org-tags-match-list-sublevels 'indented)
(make-string (1- level) ?.) "")
(org-get-heading))
(make-string level ?\s)
category
tags-list)
priority (org-get-priority txt))
(goto-char lspos)
(setq marker (org-agenda-new-marker))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker 'org-category category
'todo-state todo
'ts-date ts-date
'priority priority
'type (concat "tagsmatch" ts-date-type))
(push txt rtn))
((functionp action)
(setq org-map-continue-from nil)
(save-excursion
(setq rtn1 (funcall action))
(push rtn1 rtn)))
(t (user-error "Invalid action")))
;; if we are to skip sublevels, jump to end of subtree
(unless org-tags-match-list-sublevels
(org-end-of-subtree t)
(backward-char 1))))
;; Get the correct position from where to continue
(if org-map-continue-from
(goto-char org-map-continue-from)
(and (= (point) lspos) (end-of-line 1))))))
(when (and (eq action 'sparse-tree) (when (and (eq action 'sparse-tree)
(not org-sparse-tree-open-archived-trees)) (not org-sparse-tree-open-archived-trees))
(org-hide-archived-subtrees (point-min) (point-max))) (org-hide-archived-subtrees (point-min) (point-max)))