From 4d152b994e889d09143b68fe3da9731d69087f2c Mon Sep 17 00:00:00 2001 From: Nicolas Goaziou Date: Fri, 20 Apr 2018 10:45:19 +0200 Subject: [PATCH] Rewrite tags setting functions * lisp/org.el (org-setting-tags): Remove variable. (org-set-tags-command): Change signature. For interactive use only. (org-set-tags-to): Remove function. (org-align-all-tags): Remove function. (org-align-tags): New function. (org-set-tags): Change signature. For non-interactive use only. (org-promote): (org-demote): (org-refile): (org-todo): (org-priority): (org-toggle-tag): (org-entry-put): (org-fix-tags-on-the-fly): (org-ctrl-c-ctrl-c): (org-delete-indentation): (org-return): (org-kill-line): Apply signature change. Use new functions. * lisp/ox-beamer.el (org-beamer-property-changed): (org-beamer-select-environment): Apply signature change. Use new functions. * testing/lisp/test-org-archive.el (test-org-archive/to-archive-sibling): Update test. * testing/lisp/test-org.el (test-org/set-tags): Add tests. (test-org/set-tags-command): New test. (test-org/set-tags-to): Remove test. --- lisp/org-agenda.el | 2 +- lisp/org-archive.el | 2 +- lisp/org-capture.el | 4 +- lisp/org-colview.el | 2 +- lisp/org-compat.el | 7 + lisp/org-list.el | 2 +- lisp/org-mobile.el | 4 +- lisp/org-mouse.el | 18 +- lisp/org.el | 300 +++++++++++++------------------ lisp/ox-beamer.el | 4 +- testing/lisp/test-org-archive.el | 6 +- testing/lisp/test-org.el | 148 ++++++++++++--- 12 files changed, 267 insertions(+), 232 deletions(-) diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el index 7c74b9df1..3aac9d8af 100644 --- a/lisp/org-agenda.el +++ b/lisp/org-agenda.el @@ -9077,7 +9077,7 @@ Called with a universal prefix arg, show the priority instead of setting it." (org-show-context 'agenda) (if tag (org-toggle-tag tag onoff) - (call-interactively 'org-set-tags)) + (call-interactively #'org-set-tags-command)) (end-of-line 1) (setq newhead (org-get-heading))) (org-agenda-change-all-lines newhead hdmarker) diff --git a/lisp/org-archive.el b/lisp/org-archive.el index 385a1bf40..00b3db733 100644 --- a/lisp/org-archive.el +++ b/lisp/org-archive.el @@ -366,7 +366,7 @@ direct children of this heading." (or (and (eq org-archive-subtree-add-inherited-tags 'infile) infile-p) (eq org-archive-subtree-add-inherited-tags t)) - (org-set-tags-to all-tags)) + (org-set-tags all-tags)) ;; Mark the entry as done (when (and org-archive-mark-done (let ((case-fold-search nil)) diff --git a/lisp/org-capture.el b/lisp/org-capture.el index 02f9e3df3..0d6665d4c 100644 --- a/lisp/org-capture.el +++ b/lisp/org-capture.el @@ -1695,9 +1695,7 @@ The template may still contain \"%?\" for cursor positioning." (unless (eq (char-before) ?:) (insert ":")) (insert ins) (unless (eq (char-after) ?:) (insert ":")) - (and (org-at-heading-p) - (let ((org-ignore-region t)) - (org-set-tags nil 'align)))))) + (when (org-at-heading-p) (org-align-tags))))) ((or "C" "L") (let ((insert-fun (if (equal key "C") #'insert (lambda (s) (org-insert-link 0 s))))) diff --git a/lisp/org-colview.el b/lisp/org-colview.el index 139cea27c..d7011f016 100644 --- a/lisp/org-colview.el +++ b/lisp/org-colview.el @@ -585,7 +585,7 @@ Where possible, use the standard interface for changing this line." (if (eq org-fast-tag-selection-single-key 'expert) t org-fast-tag-selection-single-key))) - (call-interactively #'org-set-tags))))) + (call-interactively #'org-set-tags-command))))) ("DEADLINE" (lambda () (org-with-point-at pom (call-interactively #'org-deadline)))) diff --git a/lisp/org-compat.el b/lisp/org-compat.el index 2a617d35a..f6dd12801 100644 --- a/lisp/org-compat.el +++ b/lisp/org-compat.el @@ -400,6 +400,13 @@ use of this function is for the stuck project list." (declare (obsolete "use `org-make-tag-string' instead." "Org 9.2")) (org-make-tag-string (org-get-tags nil t))) +(define-obsolete-function-alias 'org-set-tags-to 'org-set-tags "Org 9.2") + +(defun org-align-all-tags () + "Align the tags in all headings." + (declare (obsolete "use `org-align-tags' instead." "Org 9.2")) + (org-align-tags t)) + ;;;; Obsolete link types (eval-after-load 'org diff --git a/lisp/org-list.el b/lisp/org-list.el index 100e06a0b..5ca7da732 100644 --- a/lisp/org-list.el +++ b/lisp/org-list.el @@ -830,7 +830,7 @@ This function modifies STRUCT." Metadata are tags, planning information and properties drawers." (save-match-data (org-with-wide-buffer - (org-set-tags-to nil) + (org-set-tags nil) (delete-region (line-beginning-position 2) (save-excursion (org-end-of-meta-data) diff --git a/lisp/org-mobile.el b/lisp/org-mobile.el index 28b1157fe..95851e155 100644 --- a/lisp/org-mobile.el +++ b/lisp/org-mobile.el @@ -1007,7 +1007,7 @@ be returned that indicates what went wrong." ((or (org-mobile-tags-same-p current old1) (eq org-mobile-force-mobile-change t) (memq 'tags org-mobile-force-mobile-change)) - (org-set-tags-to new1) t) + (org-set-tags new1) t) (t (error "Tags before change were expected as \"%s\", but are \"%s\"" (or old "") (or current ""))))) @@ -1036,7 +1036,7 @@ be returned that indicates what went wrong." (goto-char (match-beginning 4)) (insert new) (delete-region (point) (+ (point) (length current))) - (org-set-tags nil 'align)) + (org-align-tags)) (t (error "Heading changed in MobileOrg and on the computer"))))))) ((eq what 'addheading) diff --git a/lisp/org-mouse.el b/lisp/org-mouse.el index 426e21864..45b4d5604 100644 --- a/lisp/org-mouse.el +++ b/lisp/org-mouse.el @@ -434,22 +434,12 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:" `(lambda (tag) (member tag (quote ,tags))) )) '("--" - ["Align Tags Here" (org-set-tags nil t) t] - ["Align Tags in Buffer" (org-set-tags t t) t] - ["Set Tags ..." (org-set-tags) t]))) + ["Align Tags Here" (org-align-tags) t] + ["Align Tags in Buffer" (org-align-tags t) t] + ["Set Tags ..." (org-set-tags-command) t]))) (defun org-mouse-set-tags (tags) - (save-excursion - ;; remove existing tags first - (beginning-of-line) - (when (org-mouse-re-search-line ":\\(\\([A-Za-z_]+:\\)+\\)") - (replace-match "")) - - ;; set new tags if any - (when tags - (end-of-line) - (insert " " (org-make-tag-string tags)) - (org-set-tags nil t)))) + (org-set-tags tags)) (defun org-mouse-insert-checkbox () (interactive) diff --git a/lisp/org.el b/lisp/org.el index cde3f1951..cabd5cb99 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -184,6 +184,7 @@ Stars are put in group 1 and the trimmed body in group 2.") (defvar ffap-url-regexp) (defvar org-element-paragraph-separate) +(defvar org-indent-indentation-per-level) ;; load languages based on value of `org-babel-load-languages' (defvar org-babel-load-languages) @@ -7573,7 +7574,7 @@ unconditionally." (org-end-of-subtree t t)) (t (org-end-of-subtree t t)))) - (unless (bolp) (insert "\n")) ;ensure final newline + (unless (bolp) (insert "\n")) ;ensure final newline (unless (and blank? (org-previous-line-empty-p)) (org-N-empty-lines-before-current (if blank? 1 0))) (insert stars " \n") @@ -7593,7 +7594,7 @@ unconditionally." ;; Preserve tags. (let ((split (delete-and-extract-region (point) (match-end 4)))) (if (looking-at "[ \t]*$") (replace-match "") - (org-set-tags nil t)) + (org-align-tags)) (end-of-line) (when blank? (insert "\n")) (insert "\n" stars " ") @@ -7696,7 +7697,7 @@ Set it to HEADING when provided." (if old (replace-match new t t nil 4) (goto-char (or (match-end 3) (match-end 2) (match-end 1))) (insert " " new)) - (org-set-tags nil t) + (org-align-tags) (when (looking-at "[ \t]*$") (replace-match "")))))))) (defun org-insert-heading-after-current () @@ -7892,7 +7893,7 @@ odd number. Returns values greater than 0." (user-error "Cannot promote to level 0. UNDO to recover if necessary")) (t (replace-match up-head nil t))) (unless (= level 1) - (when org-auto-align-tags (org-set-tags nil 'ignore-column)) + (when org-auto-align-tags (org-align-tags)) (when org-adapt-indentation (org-fixup-indentation (- diff)))) (run-hooks 'org-after-promote-entry-hook)))) @@ -7906,7 +7907,7 @@ odd number. Returns values greater than 0." (down-head (concat (make-string (org-get-valid-level level 1) ?*) " ")) (diff (abs (- level (length down-head) -1)))) (replace-match down-head nil t) - (when org-auto-align-tags (org-set-tags nil 'ignore-column)) + (when org-auto-align-tags (org-align-tags)) (when org-adapt-indentation (org-fixup-indentation diff)) (run-hooks 'org-after-demote-entry-hook)))) @@ -11315,7 +11316,7 @@ prefix argument (`C-u C-u C-u C-c C-w')." (save-excursion (org-add-log-note)))) (and org-auto-align-tags (let ((org-loop-over-headlines-in-active-region nil)) - (org-set-tags nil t))) + (org-align-tags))) (let ((bookmark-name (plist-get org-bookmark-names-plist :last-refile))) (when bookmark-name @@ -11856,8 +11857,6 @@ insert an empty block." If the last change removed the TODO tag or switched to DONE, then this is nil.") -(defvar org-setting-tags nil) ; dynamically scoped - (defvar org-todo-setup-filter-hook nil "Hook for functions that pre-filter todo specs. Each function takes a todo spec and returns either nil or the spec @@ -12129,7 +12128,7 @@ When called through ELisp, arg is also interpreted in the following way: (org-add-log-setup 'state org-state this dolog))) ;; Fixup tag positioning. (org-todo-trigger-tag-changes org-state) - (and org-auto-align-tags (not org-setting-tags) (org-set-tags nil t)) + (when org-auto-align-tags (org-align-tags)) (when org-provide-todo-statistics (org-update-parent-todo-statistics)) (run-hooks 'org-after-todo-state-change-hook) @@ -13557,7 +13556,7 @@ ACTION can be `set', `up', `down', or a character." (insert " [#" news "]")) (goto-char (match-beginning 3)) (insert "[#" news "] ")))) - (org-set-tags nil 'align)) + (org-align-tags)) (if remove (message "Priority removed") (message "Priority of current item set to %s" news))))) @@ -14181,8 +14180,7 @@ If ONOFF is `on' or `off', don't toggle but set to this state." (setq res t) (cl-pushnew tag current :test #'equal)) (_ (setq current (delete tag current)))) - (org-set-tags-to (nreverse current)) - (run-hooks 'org-after-tags-change-hook) + (org-set-tags (nreverse current)) res))) (defun org--align-tags-here (to-col) @@ -14203,163 +14201,114 @@ Assume point is on a headline." ;; before tags. (when (< pos (point)) (goto-char pos))))) -(defun org-set-tags-command (&optional arg just-align) - "Call the set-tags command for the current entry." - (interactive "P") - (if (or (org-at-heading-p) (and arg (org-before-first-heading-p))) - (org-set-tags arg just-align) - (save-excursion - (unless (and (org-region-active-p) - org-loop-over-headlines-in-active-region) - (org-back-to-heading t)) - (org-set-tags arg just-align)))) +(defun org-set-tags-command (&optional arg) + "Set the tags for the current visible entry. -(defun org-set-tags-to (data) - "Set the tags of the current entry to DATA, replacing current tags. -DATA may be a tags string like \":aa:bb:cc:\", or a list of tags. -If DATA is nil or the empty string, all tags are removed." - (interactive "sTags: ") - (let ((data - (pcase (if (stringp data) (org-trim data) data) - ((or `nil "") nil) - ((pred listp) (org-make-tag-string data)) - ((pred stringp) - (org-make-tag-string (org-split-string data ":+"))) - (_ (error "Invalid tag specification: %S" data))))) +When called with `\\[universal-argument]' prefix argument ARG, +realign all tags in headings in the current buffer. If a region +is active, set tags for all headlines in the region. + +This function is for interactive use only; +in Lisp code use `org-set-tags' instead." + (interactive "P") + (cond + (arg (org-align-tags t)) + ((and (org-region-active-p) org-loop-over-headlines-in-active-region) + ;; Disable `org-loop-over-headlines-in-active-region' for + ;; successive calls. + (let (org-loop-over-headlines-in-active-region) + (org-map-entries + #'org-set-tags-command + nil + (if (eq org-loop-over-headlines-in-active-region 'start-level) + 'region-start-level + 'region) + (lambda () (when (org-invisible-p) (org-end-of-subtree nil t)))))) + (t + (org-back-to-heading) + (let* ((all-tags (org-get-tags)) + (table (setq org-last-tags-completion-table + (org-tag-add-to-alist + (and org-complete-tags-always-offer-all-agenda-tags + (org-global-tags-completion-table + (org-agenda-files))) + (or org-current-tag-alist (org-get-buffer-tags))))) + (current-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)) + (tags + (replace-regexp-in-string + ;; Ignore all forbidden characters in tags. + "[^[:alnum:]_@#%]+" ":" + (if (or (eq t org-use-fast-tag-selection) + (and org-use-fast-tag-selection + (delq nil (mapcar #'cdr table)))) + (org-fast-tag-selection + current-tags + inherited-tags + table + (and org-fast-tag-selection-include-todo org-todo-key-alist)) + (let ((org-add-colon-after-tag-completion (< 1 (length table)))) + (org-trim (completing-read + "Tags: " + #'org-tags-completion-function + nil nil current-tags 'org-tags-history))))))) + (org-set-tags tags))))) + +(defun org-align-tags (&optional all) + "Align tags in current entry. +When optional argument ALL is non-nil, align all tags in the +visible part of the buffer." + (save-excursion + (if all (goto-char (point-min)) (org-back-to-heading t)) + (catch :single + (while (re-search-forward org-tag-line-re nil t) + (let* ((offset (if (bound-and-true-p org-indent-mode) + (* (1- org-indent-indentation-per-level) + (1- (org-current-level))) + 0)) + (tags-column (+ org-tags-column + (if (> org-tags-column 0) (- offset) offset)))) + (beginning-of-line) + (org--align-tags-here tags-column) + (if all (forward-line) (throw :single nil))))))) + +(defun org-set-tags (tags) + "Set the tags of the current entry to TAGS, replacing current tags. + +TAGS may be a tags string like \":aa:bb:cc:\", or a list of tags. +If TAGS is nil or the empty string, all tags are removed. + +This function assumes point is on a headline." + (let ((tags (pcase tags + ((pred listp) tags) + ((pred stringp) (split-string (org-trim tags) ":" t)) + (_ (error "Invalid tag specification: %S" tags)))) + (change-flag nil)) + (when (functionp org-tags-sort-function) + (setq tags (sort tags org-tags-sort-function))) (org-with-wide-buffer - (org-back-to-heading t) - (let ((case-fold-search nil)) (looking-at org-complex-heading-regexp)) - (when (or (match-end 5) data) - (goto-char (or (match-beginning 5) (line-end-position))) + (unless (equal tags (org-get-tags nil t)) + (setq change-flag t) + ;; Delete previous tags and any trailing white space. + (goto-char (if (looking-at org-tag-line-re) (match-beginning 1) + (line-end-position))) (skip-chars-backward " \t") (delete-region (point) (line-end-position)) - (when data - (insert " " data) - (org-set-tags nil 'align)))))) - -(defun org-align-all-tags () - "Align the tags in all headings." - (interactive) - (save-excursion - (or (ignore-errors (org-back-to-heading t)) - (outline-next-heading)) - (if (org-at-heading-p) - (org-set-tags t) - (message "No headings")))) - -(defvar org-indent-indentation-per-level) -(defun org-set-tags (&optional arg just-align) - "Set the tags for the current headline. -With prefix ARG, realign all tags in headings in the current buffer. -When JUST-ALIGN is non-nil, only align tags." - (interactive "P") - (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) - (let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level) - 'region-start-level - 'region)) - org-loop-over-headlines-in-active-region) - (org-map-entries - ;; We don't use ARG and JUST-ALIGN here because these args - ;; are not useful when looping over headlines. - #'org-set-tags - org-loop-over-headlines-in-active-region - cl - '(when (org-invisible-p) (org-end-of-subtree nil t)))) - (let ((org-setting-tags t)) - (if arg - (save-excursion - (goto-char (point-min)) - (while (re-search-forward org-outline-regexp-bol nil t) - (org-set-tags nil t) - (end-of-line)) - (message "All tags realigned to column %d" org-tags-column)) - (let* ((current (org-make-tag-string (org-get-tags nil t))) - (tags - (if just-align current - ;; Get a new set of tags from the user. - (save-excursion - (let* ((table - (setq - org-last-tags-completion-table - (org-tag-add-to-alist - (and - org-complete-tags-always-offer-all-agenda-tags - (org-global-tags-completion-table - (org-agenda-files))) - (or org-current-tag-alist - (org-get-buffer-tags))))) - (current-tags (org-split-string current ":")) - (inherited-tags - (nreverse (nthcdr (length current-tags) - (nreverse (org-get-tags)))))) - (replace-regexp-in-string - "\\([-+&]+\\|,\\)" - ":" - (if (or (eq t org-use-fast-tag-selection) - (and org-use-fast-tag-selection - (delq nil (mapcar #'cdr table)))) - (org-fast-tag-selection - current-tags inherited-tags table - (and org-fast-tag-selection-include-todo - org-todo-key-alist)) - (let ((org-add-colon-after-tag-completion - (< 1 (length table)))) - (org-trim - (completing-read - "Tags: " - #'org-tags-completion-function - nil nil current 'org-tags-history)))))))))) - - (when org-tags-sort-function - (setq tags - (mapconcat - #'identity - (sort (org-split-string tags "[^[:alnum:]_@#%]+") - org-tags-sort-function) - ":"))) - - (if (or (string= ":" tags) - (string= "::" tags)) - (setq tags "")) - (if (not (org-string-nw-p tags)) (setq tags "") - (unless (string-suffix-p ":" tags) (setq tags (concat tags ":"))) - (unless (string-prefix-p ":" tags) (setq tags (concat ":" tags)))) - - ;; Insert new tags at the correct column. - (unless (equal current tags) - (save-excursion - (beginning-of-line) - (let ((case-fold-search nil)) - (looking-at org-complex-heading-regexp)) - ;; Remove current tags, if any. - (when (match-end 5) (replace-match "" nil nil nil 5)) - ;; Insert new tags, if any. Otherwise, remove trailing - ;; white spaces. - (end-of-line) - (if (not (equal tags "")) - ;; When text is being inserted on an invisible - ;; region boundary, it can be inadvertently sucked - ;; into invisibility. - (org-flag-region (point) (progn (insert " " tags) (point)) - nil - 'outline) - (skip-chars-backward " \t") - (delete-region (point) (line-end-position))))) - ;; Align tags, if any. Fix tags column if `org-indent-mode' - ;; is on. - (unless (equal tags "") - (let* ((level (save-excursion - (beginning-of-line) - (skip-chars-forward "\\*"))) - (offset (if (bound-and-true-p org-indent-mode) - (* (1- org-indent-indentation-per-level) - (1- level)) - 0)) - (tags-column - (+ org-tags-column - (if (> org-tags-column 0) (- offset) offset)))) - (org--align-tags-here tags-column)))) - (unless just-align (run-hooks 'org-after-tags-change-hook)))))) + (when tags + (save-excursion (insert " " (org-make-tag-string tags))) + ;; When text is being inserted on an invisible region + ;; boundary, it can be inadvertently sucked into + ;; invisibility. + (unless (org-invisible-p (line-beginning-position)) + (org-flag-region (point) (line-end-position) nil 'outline)))) + ;; Align tags, if any. Fix tags column if `org-indent-mode' is + ;; on. + (when tags (org-align-tags)) + (when change-flag (run-hooks 'org-after-tags-change-hook))))) (defun org-change-tag-in-region (beg end tag off) "Add or remove TAG for each entry in the region. @@ -15398,10 +15347,10 @@ decreases scheduled or deadline date by one day." ((not (member value org-todo-keywords-1)) (user-error "\"%s\" is not a valid TODO state" value))) (org-todo value) - (org-set-tags nil 'align)) + (org-align-tags)) ((equal property "PRIORITY") (org-priority (if (org-string-nw-p value) (string-to-char value) ?\s)) - (org-set-tags nil 'align)) + (org-align-tags)) ((equal property "SCHEDULED") (forward-line) (if (and (looking-at-p org-planning-line-re) @@ -19384,12 +19333,11 @@ The detailed reaction depends on the user option `org-catch-invisible-edits'." (defun org-fix-tags-on-the-fly () "Align tags in headline at point. -Unlike to `org-set-tags', it ignores region and sorting." +Unlike to `org-align-tags', this function does nothing if point +is not currently on a headline." (when (and (eq (char-after (line-beginning-position)) ?*) ;short-circuit (org-at-heading-p)) - (let ((org-ignore-region t) - (org-tags-sort-function nil)) - (org-set-tags nil t)))) + (org-align-tags))) (defun org-delete-backward-char (N) "Like `delete-backward-char', insert whitespace at field end in tables. @@ -20243,7 +20191,7 @@ This command does many different things, depending on context: (`footnote-reference (call-interactively #'org-footnote-action)) ((or `headline `inlinetask) (save-excursion (goto-char (org-element-property :begin context)) - (call-interactively #'org-set-tags))) + (call-interactively #'org-set-tags-command))) (`item ;; At an item: `C-u C-u' sets checkbox to "[-]" ;; unconditionally, whereas `C-u' will toggle its presence. @@ -20355,7 +20303,7 @@ Use `\\[org-edit-special]' to edit table.el tables")) ((and `nil (guard (org-at-heading-p))) ;; When point is on an unsupported object type, we can miss ;; the fact that it also is at a heading. Handle it here. - (call-interactively #'org-set-tags)) + (call-interactively #'org-set-tags-command)) ((guard (run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-final-hook))) (_ @@ -20415,7 +20363,7 @@ With a non-nil optional argument, join it to the following one." ;; Adjust alignment of tags. (cond ((not tags-column)) ;no tags - (org-auto-align-tags (org-set-tags nil t)) + (org-auto-align-tags (org-align-tags)) (t (org--align-tags-here tags-column)))) ;preserve tags column (delete-indentation arg))) @@ -20489,7 +20437,7 @@ object (e.g., within a comment). In these case, you need to use ;; Adjust tag alignment. (cond ((not (and tags-column string))) - (org-auto-align-tags (org-set-tags nil t)) + (org-auto-align-tags (org-align-tags)) (t (org--align-tags-here tags-column))) ;preserve tags column (end-of-line) (org-show-entry) @@ -22827,7 +22775,7 @@ depending on context." (if (<= end (point)) ;on tags part (kill-region (point) (line-end-position)) (kill-region (point) end))) - (org-set-tags nil t)) + (org-align-tags)) (t (kill-region (point) (line-end-position))))) (defun org-yank (&optional arg) diff --git a/lisp/ox-beamer.el b/lisp/ox-beamer.el index 01cf0c91a..1d2e338ac 100644 --- a/lisp/ox-beamer.el +++ b/lisp/ox-beamer.el @@ -916,7 +916,7 @@ value." (let ((tags (cl-remove-if (lambda (x) (string-match "^B_" x)) (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)) + (org-set-tags (if env-tag (cons env-tag tags) tags)) (when env-tag (org-toggle-tag env-tag 'on))))) ((equal property "BEAMER_col") (org-toggle-tag "BMCOL" (if (org-string-nw-p value) 'on 'off))))) @@ -1075,7 +1075,7 @@ aid, but the tag does not have any semantic meaning." (org-tag-persistent-alist nil) (org-use-fast-tag-selection t) (org-fast-tag-selection-single-key t)) - (org-set-tags) + (org-set-tags-command) (let ((tags (org-get-tags nil t))) (cond ;; For a column, automatically ask for its width. diff --git a/testing/lisp/test-org-archive.el b/testing/lisp/test-org-archive.el index f66fa4bdc..c654703a0 100644 --- a/testing/lisp/test-org-archive.el +++ b/testing/lisp/test-org-archive.el @@ -83,7 +83,8 @@ (equal "* Archive :ARCHIVE:\n** H\n" (org-test-with-temp-text "* H\n" (let ((org-archive-sibling-heading "Archive") - (org-archive-tag "ARCHIVE")) + (org-archive-tag "ARCHIVE") + (org-tags-column 1)) (org-archive-to-archive-sibling) (goto-char (point-min)) (buffer-substring-no-properties @@ -93,7 +94,8 @@ (equal "* Archive :ARCHIVE:\n* Top\n** Archive :ARCHIVE:\n*** H\n" (org-test-with-temp-text "* Archive :ARCHIVE:\n* Top\n** H\n" (let ((org-archive-sibling-heading "Archive") - (org-archive-tag "ARCHIVE")) + (org-archive-tag "ARCHIVE") + (org-tags-column 0)) (org-archive-to-archive-sibling) (goto-char (point-min)) (buffer-substring-no-properties diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el index 4e47d94a6..dee650818 100644 --- a/testing/lisp/test-org.el +++ b/testing/lisp/test-org.el @@ -6111,86 +6111,176 @@ Paragraph" (ert-deftest test-org/set-tags () "Test `org-set-tags' specifications." - ;; Tags set via fast-tag-selection should be visible afterwards - (should - (let ((org-tag-alist '(("NEXT" . ?n))) - (org-fast-tag-selection-single-key t)) - (cl-letf (((symbol-function 'read-char-exclusive) (lambda () ?n)) - ((symbol-function 'window-width) (lambda (&rest args) 100))) - (org-test-with-temp-text "* Headline\nAnd its content\n* And another headline\n\nWith some content" - ;; Show only headlines - (org-content) - ;; Set NEXT tag on current entry - (org-set-tags nil nil) - ;; Move point to that NEXT tag - (search-forward "NEXT") (backward-word) - ;; And it should be visible (i.e. no overlays) - (not (overlays-at (point)))))))) - -(ert-deftest test-org/set-tags-to () - "Test `org-set-tags-to' specifications." ;; Throw an error on invalid data. (should-error (org-test-with-temp-text "* H" - (org-set-tags-to 'foo))) + (org-set-tags 'foo))) ;; `nil', an empty, and a blank string remove all tags. (should (equal "* H" (org-test-with-temp-text "* H :tag1:tag2:" - (org-set-tags-to nil) + (org-set-tags nil) (buffer-string)))) (should (equal "* H" (org-test-with-temp-text "* H :tag1:tag2:" - (org-set-tags-to "") + (org-set-tags "") (buffer-string)))) (should (equal "* H" (org-test-with-temp-text "* H :tag1:tag2:" - (org-set-tags-to " ") + (org-set-tags " ") (buffer-string)))) ;; If there's nothing to remove, just bail out. (should (equal "* H" (org-test-with-temp-text "* H" - (org-set-tags-to nil) + (org-set-tags nil) (buffer-string)))) (should (equal "* " (org-test-with-temp-text "* " - (org-set-tags-to nil) + (org-set-tags nil) (buffer-string)))) ;; If DATA is a tag string, set current tags to it, even if it means ;; replacing old tags. (should (equal "* H :tag0:" (org-test-with-temp-text "* H :tag1:tag2:" - (org-set-tags-to ":tag0:") + (let ((org-tags-column 1)) (org-set-tags ":tag0:")) (buffer-string)))) (should (equal "* H :tag0:" (org-test-with-temp-text "* H" - (org-set-tags-to ":tag0:") + (let ((org-tags-column 1)) (org-set-tags ":tag0:")) (buffer-string)))) ;; If DATA is a list, set tags to this list, even if it means ;; replacing old tags. (should (equal "* H :tag0:" (org-test-with-temp-text "* H :tag1:tag2:" - (org-set-tags-to '("tag0")) + (let ((org-tags-column 1)) (org-set-tags '("tag0"))) (buffer-string)))) (should (equal "* H :tag0:" (org-test-with-temp-text "* H" - (org-set-tags-to '("tag0")) + (let ((org-tags-column 1)) (org-set-tags '("tag0"))) (buffer-string)))) + ;; When set, apply `org-tags-sort-function'. + (should + (equal "* H :a:b:" + (org-test-with-temp-text "* H" + (let ((org-tags-column 1) + (org-tags-sort-function #'string<)) + (org-set-tags '("b" "a")) + (buffer-string))))) + ;; When new tags are identical to the previous ones, still align. + (should + (equal "* H :foo:" + (org-test-with-temp-text "* H :foo:" + (let ((org-tags-column 1)) + (org-set-tags '("foo")) + (buffer-string))))) + ;; When tags have been changed, run `org-after-tags-change-hook'. + (should + (catch :return + (org-test-with-temp-text "* H :foo:" + (let ((org-after-tags-change-hook (lambda () (throw :return t)))) + (org-set-tags '("bar")) + nil)))) + (should-not + (catch :return + (org-test-with-temp-text "* H :foo:" + (let ((org-after-tags-change-hook (lambda () (throw :return t)))) + (org-set-tags '("foo")) + nil)))) ;; Special case: handle empty headlines. (should (equal "* :tag0:" (org-test-with-temp-text "* " - (org-set-tags-to '("tag0")) + (let ((org-tags-column 1)) (org-set-tags '("tag0"))) + (buffer-string)))) + ;; Pathological case: when setting tags of a folded headline, do not + ;; let new tags being sucked into invisibility. + (should-not + (org-test-with-temp-text "* H1\nContent\n* H2\n\n Other Content" + ;; Show only headlines + (org-content) + ;; Set NEXT tag on current entry + (org-set-tags ":NEXT:") + ;; Move point to that NEXT tag + (search-forward "NEXT") (backward-word) + ;; And it should be visible (i.e. no overlays) + (overlays-at (point))))) + +(ert-deftest test-org/set-tags-command () + "Test `org-set-tags-command' specifications" + ;; Set tags at current headline. + (should + (equal "* H1 :foo:" + (org-test-with-temp-text "* H1" + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest args) ":foo:"))) + (let ((org-use-fast-tag-selection nil) + (org-tags-column 1)) + (org-set-tags-command))) + (buffer-string)))) + (should + (equal "* H1 :foo:\nContents" + (org-test-with-temp-text "* H1\nContents" + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest args) ":foo:"))) + (let ((org-use-fast-tag-selection nil) + (org-tags-column 1)) + (org-set-tags-command))) + (buffer-string)))) + ;; Strip all forbidden characters from user-entered tags. + (should + (equal "* H1 :foo:" + (org-test-with-temp-text "* H1" + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest args) ": foo *:"))) + (let ((org-use-fast-tag-selection nil) + (org-tags-column 1)) + (org-set-tags-command))) + (buffer-string)))) + ;; When a region is active and + ;; `org-loop-over-headlines-in-active-region' is non-nil, insert the + ;; same value in all headlines in region. + (should + (equal "* H1 :foo:\nContents\n* H2 :foo:" + (org-test-with-temp-text "* H1\nContents\n* H2" + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest args) ":foo:"))) + (let ((org-use-fast-tag-selection nil) + (org-loop-over-headlines-in-active-region t) + (org-tags-column 1)) + (transient-mark-mode 1) + (push-mark (point) t t) + (goto-char (point-max)) + (org-set-tags-command))) + (buffer-string)))) + (should + (equal "* H1\nContents\n* H2 :foo:" + (org-test-with-temp-text "* H1\nContents\n* H2" + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest args) ":foo:"))) + (let ((org-use-fast-tag-selection nil) + (org-loop-over-headlines-in-active-region nil) + (org-tags-column 1)) + (transient-mark-mode 1) + (push-mark (point) t t) + (goto-char (point-max)) + (org-set-tags-command))) + (buffer-string)))) + ;; With a non-nil prefix argument, align all tags in the buffer. + (should + (equal "* H1 :foo:\n* H2 :bar:" + (org-test-with-temp-text "* H1 :foo:\n* H2 :bar:" + (let ((org-tags-column 1)) (org-set-tags-command t)) (buffer-string))))) + ;;; TODO keywords