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 7 years 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
 ,#+STARTUP: align shrink
 #+END_EXAMPLE
 #+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
 *** Alphabetic sorting in tables and lists
 
 
 When sorting alphabetically, ~org-table-sort-lines~ and ~org-sort-list~
 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)
 	  (org-back-to-heading t)
 	  ;; Get context information that will be lost by moving the
 	  ;; Get context information that will be lost by moving the
 	  ;; tree.  See `org-archive-save-context-info'.
 	  ;; 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
 		 (context
 		  `((category . ,(org-get-category nil 'force-refresh))
 		  `((category . ,(org-get-category nil 'force-refresh))
 		    (file . ,file)
 		    (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)
 		(funcall cmd data old new)
 		(unless (member data '("delete" "archive" "archive-sibling"
 		(unless (member data '("delete" "archive" "archive-sibling"
 				       "addheading"))
 				       "addheading"))
-		  (when (member "FLAGGED" (org-get-tags))
+		  (when (member "FLAGGED" (org-get-tags nil t))
 		    (add-to-list 'org-mobile-last-flagged-files
 		    (add-to-list 'org-mobile-last-flagged-files
 				 (buffer-file-name)))))
 				 (buffer-file-name)))))
 	    (error (setq org-mobile-error msg)))
 	    (error (setq org-mobile-error msg)))
@@ -999,7 +999,7 @@ be returned that indicates what went wrong."
 		 old current))))
 		 old current))))
 
 
      ((eq what 'tags)
      ((eq what 'tags)
-      (setq current (org-get-tags)
+      (setq current (org-get-tags nil t)
 	    new1 (and new (org-split-string new ":+"))
 	    new1 (and new (org-split-string new ":+"))
 	    old1 (and old (org-split-string old ":+")))
 	    old1 (and old (org-split-string old ":+")))
       (cond
       (cond

+ 1 - 1
lisp/org-mouse.el

@@ -422,7 +422,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
 (defun org-mouse-tag-menu ()		;todo
 (defun org-mouse-tag-menu ()		;todo
   "Create the tags menu."
   "Create the tags menu."
   (append
   (append
-   (let ((tags (org-get-tags)))
+   (let ((tags (org-get-tags nil t)))
      (org-mouse-keyword-menu
      (org-mouse-keyword-menu
       (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
       (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
       `(lambda (tag)
       `(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)))
 				   (mapcar (lambda (x) (org-string-nw-p (car x)))
 					   org-current-tag-alist))
 					   org-current-tag-alist))
 				  (mapcar #'car (org-get-buffer-tags))))))
 				  (mapcar #'car (org-get-buffer-tags))))))
-		    (dolist (tag (org-get-tags))
+		    (dolist (tag (org-get-tags nil t))
 		      (setq lst (delete tag lst)))
 		      (setq lst (delete tag lst)))
 		    lst))
 		    lst))
 	  (and (string-match ".*:" pcomplete-stub)
 	  (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
 An archived subtree does not open during visibility cycling, and does
 not contribute to the agenda listings.")
 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
 (eval-and-compile
   (defconst org-comment-string "COMMENT"
   (defconst org-comment-string "COMMENT"
     "Entries starting with this keyword will never be exported.
     "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.
      ;; Include headline point is currently on.
      (beginning-of-line)
      (beginning-of-line)
      (while (and (< (point) end) (re-search-forward re end t))
      (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-flag-subtree t)
 	 (org-end-of-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)
 	(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 ()
 (defun org-get-buffer-tags ()
   "Get a table of all tags used in the buffer, for completion."
   "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
 ;;;; The mapping API
 
 

+ 1 - 1
lisp/ox-beamer.el

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

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

@@ -6033,12 +6033,81 @@ Paragraph<point>"
 	      (insert "x")
 	      (insert "x")
 	      (buffer-string))))))
 	      (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
   (should
    (equal '("foo" "bar")
    (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 ()
 (ert-deftest test-org/set-tags ()
   "Test `org-set-tags' specifications."
   "Test `org-set-tags' specifications."