From 3c4290e668b15c64e6d48b1926291987742476e8 Mon Sep 17 00:00:00 2001 From: Ihor Radchenko Date: Sun, 17 Oct 2021 00:00:01 +0800 Subject: [PATCH] org.el/org-scan-tags: Make use of fast `org-element-cache-map' --- lisp/org.el | 294 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 190 insertions(+), 104 deletions(-) diff --git a/lisp/org.el b/lisp/org.el index 5256fa467..2dde75da7 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -11533,115 +11533,201 @@ headlines matching this string." (when (eq action 'sparse-tree) (org-overview) (org-remove-occur-highlights)) - (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 + (if (org-element--cache-active-p) + (let ((fast-re (concat "^" + (if start-level + ;; Get the correct level to match + (concat "\\*\\{" (number-to-string start-level) "\\} ") + org-outline-regexp)))) + (org-element-cache-map + (lambda (el) + (goto-char (org-element-property :begin el)) + (setq todo (org-element-property :todo-keyword el) + level (org-element-property :level el) + category (org-entry-get-with-inheritance "CATEGORY" nil el) + tags-list (org-get-tags el) + org-scanner-tags tags-list) + (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))) + (catch :skip + (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)) + ;; 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) + ;; 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 el)) + 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)))))) + ;; 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"))) + ;; 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 (org-element-property :begin el)) + (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))))) + ;; if we are to skip sublevels, jump to end of subtree + (unless org-tags-match-list-sublevels + (goto-char (1- (org-element-property :end el)))))) + ;; Get the correct position from where to continue + (when org-map-continue-from + (goto-char org-map-continue-from)) + ;; Return nil. + 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) (not org-sparse-tree-open-archived-trees)) (org-hide-archived-subtrees (point-min) (point-max)))