Change `org-get-tags' specifications

* lisp/org.el (org-tag-line-re): New variable.
(org-hide-archived-subtrees):
(org-get-buffer-tags): Use new function.
(org--get-local-tags): New function.
(org-get-tags): Change meaning.  Now get all inherited tags.  Change
signature.
* lisp/org-archive.el (org-archive-subtree):
* lisp/org-mobile.el (org-mobile-apply):
(org-mobile-edit):
* lisp/org-mouse.el (org-mouse-tag-menu):
* lisp/org-pcomplete.el (pcomplete/org-mode/tag): Apply change

* testing/lisp/test-org.el (test-org/get-tags): New test.
(test-org/tags-at): Remove test.
This commit is contained in:
Nicolas Goaziou 2018-04-18 17:28:52 +02:00
parent 6457a9e4e6
commit fbe56f89f7
8 changed files with 141 additions and 25 deletions

View File

@ -106,6 +106,14 @@ document, use =shrink= value instead, or in addition to align:
,#+STARTUP: align shrink
#+END_EXAMPLE
*** ~org-get-tags~ meaning change
Function ~org-get-tags~ used to return local tags to the current
headline. It now returns the all the inherited tags in addition to
the local tags. In order to get the old behaviour back, you can use:
: (org-get-tags nil t)
*** Alphabetic sorting in tables and lists
When sorting alphabetically, ~org-table-sort-lines~ and ~org-sort-list~

View File

@ -271,9 +271,15 @@ direct children of this heading."
(org-back-to-heading t)
;; Get context information that will be lost by moving the
;; tree. See `org-archive-save-context-info'.
(let* ((all-tags (org-get-tags-at))
(local-tags (org-get-tags))
(inherited-tags (org-delete-all local-tags all-tags))
(let* ((all-tags (org-get-tags))
(local-tags
(cl-remove-if (lambda (tag)
(get-text-property 0 'inherited tag))
all-tags))
(inherited-tags
(cl-remove-if-not (lambda (tag)
(get-text-property 0 'inherited tag))
all-tags))
(context
`((category . ,(org-get-category nil 'force-refresh))
(file . ,file)

View File

@ -874,7 +874,7 @@ If BEG and END are given, only do this in that region."
(funcall cmd data old new)
(unless (member data '("delete" "archive" "archive-sibling"
"addheading"))
(when (member "FLAGGED" (org-get-tags))
(when (member "FLAGGED" (org-get-tags nil t))
(add-to-list 'org-mobile-last-flagged-files
(buffer-file-name)))))
(error (setq org-mobile-error msg)))
@ -999,7 +999,7 @@ be returned that indicates what went wrong."
old current))))
((eq what 'tags)
(setq current (org-get-tags)
(setq current (org-get-tags nil t)
new1 (and new (org-split-string new ":+"))
old1 (and old (org-split-string old ":+")))
(cond

View File

@ -422,7 +422,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(defun org-mouse-tag-menu () ;todo
"Create the tags menu."
(append
(let ((tags (org-get-tags)))
(let ((tags (org-get-tags nil t)))
(org-mouse-keyword-menu
(sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
`(lambda (tag)

View File

@ -327,7 +327,7 @@ This needs more work, to handle headings with lots of spaces in them."
(mapcar (lambda (x) (org-string-nw-p (car x)))
org-current-tag-alist))
(mapcar #'car (org-get-buffer-tags))))))
(dolist (tag (org-get-tags))
(dolist (tag (org-get-tags nil t))
(setq lst (delete tag lst)))
lst))
(and (string-match ".*:" pcomplete-stub)

View File

@ -520,6 +520,12 @@ but the stars and the body are.")
An archived subtree does not open during visibility cycling, and does
not contribute to the agenda listings.")
(defconst org-tag-line-re
"^\\*+ \\(?:.*[ \t]\\)?\\(:\\([[:alnum:]_@#%:]+\\):\\)[ \t]*$"
"Regexp matching tags in a headline.
Tags are stored in match group 1. Match group 2 stores the tags
without the enclosing colons.")
(eval-and-compile
(defconst org-comment-string "COMMENT"
"Entries starting with this keyword will never be exported.
@ -4621,7 +4627,7 @@ STATE should be one of the symbols listed in the docstring of
;; 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))
(when (member org-archive-tag (org-get-tags nil t))
(org-flag-subtree t)
(org-end-of-subtree t))))))
@ -14713,21 +14719,48 @@ Returns the new tags string, or nil to not change the current settings."
(match-string-no-properties 1)
"")))
(defun org-get-tags ()
"Get the list of tags specified in the current headline."
(org-split-string (org-get-tags-string) ":"))
(defun org--get-local-tags ()
"Return list of tags for the current headline.
Assume point is at the beginning of the headline."
(and (looking-at org-tag-line-re)
(split-string (match-string-no-properties 2) ":" t)))
(defun org-get-tags (&optional pos local)
"Get the list of tags specified in the current headline.
When argument POS is non-nil, retrieve tags for headline at POS.
Accoring to `org-use-tags-inheritance', tags may be inherited
from parent headlines, and from the whole document, through
`org-file-tags'. However, when optional argument LOCAL is
non-nil, only return tags really specified in the considered
headline.
Inherited tags have the `inherited' text property."
(if (and org-trust-scanner-tags
(or (not pos) (eq pos (point)))
(not local))
org-scanner-tags
(org-with-point-at (or pos (point))
(unless (org-before-first-heading-p)
(org-back-to-heading t)
(let ((tags (org--get-local-tags)))
(if (or local (not org-use-tag-inheritance)) tags
(while (org-up-heading-safe)
(setq tags (append (mapcar #'org-add-prop-inherited
(org--get-local-tags))
tags)))
(org-remove-uninherited-tags
(delete-dups (append org-file-tags tags)))))))))
(defun org-get-buffer-tags ()
"Get a table of all tags used in the buffer, for completion."
(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))))))
(org-with-point-at 1
(let (tags)
(while (re-search-forward org-tag-line-re nil t)
(setq tags (nconc (split-string (match-string-no-properties 2) ":")
tags)))
(mapcar #'list (delete-dups (append org-file-tags tags))))))
;;;; The mapping API

View File

@ -914,7 +914,7 @@ value."
(org-back-to-heading t)
;; Filter out Beamer-related tags and install environment tag.
(let ((tags (cl-remove-if (lambda (x) (string-match "^B_" x))
(org-get-tags)))
(org-get-tags nil t)))
(env-tag (and (org-string-nw-p value) (concat "B_" value))))
(org-set-tags-to (if env-tag (cons env-tag tags) tags))
(when env-tag (org-toggle-tag env-tag 'on)))))

View File

@ -6033,12 +6033,81 @@ Paragraph<point>"
(insert "x")
(buffer-string))))))
(ert-deftest test-org/tags-at ()
(ert-deftest test-org/get-tags ()
"Test `org-get-tags' specifications."
;; Standard test.
(should
(equal '("foo")
(org-test-with-temp-text "* Test :foo:" (org-get-tags))))
(should
(equal '("foo" "bar")
(org-test-with-temp-text
"* T<point>est :foo:bar:"
(org-get-tags-at)))))
(org-test-with-temp-text "* Test :foo:bar:" (org-get-tags))))
;; Return nil when there is no tag.
(should-not
(org-test-with-temp-text "* Test" (org-get-tags)))
;; Tags are inherited from parent headlines.
(should
(equal '("tag")
(let ((org-use-tag-inheritance t))
(org-test-with-temp-text "* H0 :foo:\n* H1 :tag:\n<point>** H2"
(org-get-tags)))))
;; Tags are inherited from `org-file-tags'.
(should
(equal '("tag")
(org-test-with-temp-text "* H1"
(let ((org-file-tags '("tag"))
(org-use-tag-inheritance t))
(org-get-tags)))))
;; Only inherited tags have the `inherited' text property.
(should
(get-text-property 0 'inherited
(org-test-with-temp-text "* H1 :foo:\n** <point>H2 :bar:"
(let ((org-use-tag-inheritance t))
(assoc-string "foo" (org-get-tags))))))
(should-not
(get-text-property 0 'inherited
(org-test-with-temp-text "* H1 :foo:\n** <point>H2 :bar:"
(let ((org-use-tag-inheritance t))
(assoc-string "bar" (org-get-tags))))))
;; Obey to `org-use-tag-inheritance'.
(should-not
(org-test-with-temp-text "* H1 :foo:\n** <point>H2 :bar:"
(let ((org-use-tag-inheritance nil))
(assoc-string "foo" (org-get-tags)))))
(should-not
(org-test-with-temp-text "* H1 :foo:\n** <point>H2 :bar:"
(let ((org-use-tag-inheritance nil)
(org-file-tags '("foo")))
(assoc-string "foo" (org-get-tags)))))
(should-not
(org-test-with-temp-text "* H1 :foo:bar:\n** <point>H2 :baz:"
(let ((org-use-tag-inheritance '("bar")))
(assoc-string "foo" (org-get-tags)))))
(should
(org-test-with-temp-text "* H1 :foo:bar:\n** <point>H2 :baz:"
(let ((org-use-tag-inheritance '("bar")))
(assoc-string "bar" (org-get-tags)))))
(should-not
(org-test-with-temp-text "* H1 :foo:bar:\n** <point>H2 :baz:"
(let ((org-use-tag-inheritance "b.*"))
(assoc-string "foo" (org-get-tags)))))
(should
(org-test-with-temp-text "* H1 :foo:bar:\n** <point>H2 :baz:"
(let ((org-use-tag-inheritance "b.*"))
(assoc-string "bar" (org-get-tags)))))
;; When optional argument LOCAL is non-nil, ignore tag inheritance.
(should
(equal '("baz")
(org-test-with-temp-text "* H1 :foo:bar:\n** <point>H2 :baz:"
(let ((org-use-tag-inheritance t))
(org-get-tags nil t)))))
;; When optional argument POS is non-nil, get tags there instead.
(should
(equal '("foo")
(org-test-with-temp-text "* H1 :foo:\n* <point>H2 :bar:"
(org-get-tags 1))))
;; Pathological case: tagged headline with an empty body.
(should (org-test-with-temp-text "* :tag:" (org-get-tags))))
(ert-deftest test-org/set-tags ()
"Test `org-set-tags' specifications."