Browse Source

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.
Nicolas Goaziou 1 year ago
parent
commit
fbe56f89f7
8 changed files with 141 additions and 25 deletions
  1. 8 0
      etc/ORG-NEWS
  2. 9 3
      lisp/org-archive.el
  3. 2 2
      lisp/org-mobile.el
  4. 1 1
      lisp/org-mouse.el
  5. 1 1
      lisp/org-pcomplete.el
  6. 46 13
      lisp/org.el
  7. 1 1
      lisp/ox-beamer.el
  8. 73 4
      testing/lisp/test-org.el

+ 8 - 0
etc/ORG-NEWS

@@ -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~

+ 9 - 3
lisp/org-archive.el

@@ -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)

+ 2 - 2
lisp/org-mobile.el

@@ -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

+ 1 - 1
lisp/org-mouse.el

@@ -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)

+ 1 - 1
lisp/org-pcomplete.el

@@ -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)

+ 46 - 13
lisp/org.el

@@ -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
 

+ 1 - 1
lisp/ox-beamer.el

@@ -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)))))

+ 73 - 4
testing/lisp/test-org.el

@@ -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."