forked from mirrors/org-mode
Fix fast tag selection affecting wrong line
* lisp/org.el (org-fast-tag-selection): Wrap `save-window-excursion' with `save-excursion'. In the case when the tags are changed remotely from the agenda, and the affected buffer is already visible in another window, the tag change was applied to the currently visible line in the target buffer, not the headline in the agenda.
This commit is contained in:
Ingo Lohmar
Nicolas Goaziou
parent
e95ac0bac3
commit
d1ce59571f
317
lisp/org.el
317
lisp/org.el
|
|
@ -14564,168 +14564,169 @@ Returns the new tags string, or nil to not change the current settings."
|
|||
" "
|
||||
(make-string (- org-tags-column (current-column)) ?\ ))))))
|
||||
(move-overlay org-tags-overlay ov-start ov-end)
|
||||
(save-window-excursion
|
||||
(if expert
|
||||
(set-buffer (get-buffer-create " *Org tags*"))
|
||||
(delete-other-windows)
|
||||
(set-window-buffer (split-window-vertically) (get-buffer-create " *Org tags*"))
|
||||
(org-switch-to-buffer-other-window " *Org tags*"))
|
||||
(erase-buffer)
|
||||
(setq-local org-done-keywords done-keywords)
|
||||
(org-fast-tag-insert "Inherited" inherited i-face "\n")
|
||||
(org-fast-tag-insert "Current" current c-face "\n\n")
|
||||
(org-fast-tag-show-exit exit-after-next)
|
||||
(org-set-current-tags-overlay current ov-prefix)
|
||||
(setq tbl fulltable char ?a cnt 0)
|
||||
(while (setq e (pop tbl))
|
||||
(cond
|
||||
((eq (car e) :startgroup)
|
||||
(push '() groups) (setq ingroup t)
|
||||
(unless (zerop cnt)
|
||||
(setq cnt 0)
|
||||
(insert "\n"))
|
||||
(insert (if (cdr e) (format "%s: " (cdr e)) "") "{ "))
|
||||
((eq (car e) :endgroup)
|
||||
(setq ingroup nil cnt 0)
|
||||
(insert "}" (if (cdr e) (format " (%s) " (cdr e)) "") "\n"))
|
||||
((eq (car e) :startgrouptag)
|
||||
(setq intaggroup t)
|
||||
(unless (zerop cnt)
|
||||
(setq cnt 0)
|
||||
(insert "\n"))
|
||||
(insert "[ "))
|
||||
((eq (car e) :endgrouptag)
|
||||
(setq intaggroup nil cnt 0)
|
||||
(insert "]\n"))
|
||||
((equal e '(:newline))
|
||||
(unless (zerop cnt)
|
||||
(setq cnt 0)
|
||||
(insert "\n")
|
||||
(setq e (car tbl))
|
||||
(while (equal (car tbl) '(:newline))
|
||||
(save-excursion
|
||||
(save-window-excursion
|
||||
(if expert
|
||||
(set-buffer (get-buffer-create " *Org tags*"))
|
||||
(delete-other-windows)
|
||||
(set-window-buffer (split-window-vertically) (get-buffer-create " *Org tags*"))
|
||||
(org-switch-to-buffer-other-window " *Org tags*"))
|
||||
(erase-buffer)
|
||||
(setq-local org-done-keywords done-keywords)
|
||||
(org-fast-tag-insert "Inherited" inherited i-face "\n")
|
||||
(org-fast-tag-insert "Current" current c-face "\n\n")
|
||||
(org-fast-tag-show-exit exit-after-next)
|
||||
(org-set-current-tags-overlay current ov-prefix)
|
||||
(setq tbl fulltable char ?a cnt 0)
|
||||
(while (setq e (pop tbl))
|
||||
(cond
|
||||
((eq (car e) :startgroup)
|
||||
(push '() groups) (setq ingroup t)
|
||||
(unless (zerop cnt)
|
||||
(setq cnt 0)
|
||||
(insert "\n"))
|
||||
(insert (if (cdr e) (format "%s: " (cdr e)) "") "{ "))
|
||||
((eq (car e) :endgroup)
|
||||
(setq ingroup nil cnt 0)
|
||||
(insert "}" (if (cdr e) (format " (%s) " (cdr e)) "") "\n"))
|
||||
((eq (car e) :startgrouptag)
|
||||
(setq intaggroup t)
|
||||
(unless (zerop cnt)
|
||||
(setq cnt 0)
|
||||
(insert "\n"))
|
||||
(insert "[ "))
|
||||
((eq (car e) :endgrouptag)
|
||||
(setq intaggroup nil cnt 0)
|
||||
(insert "]\n"))
|
||||
((equal e '(:newline))
|
||||
(unless (zerop cnt)
|
||||
(setq cnt 0)
|
||||
(insert "\n")
|
||||
(setq tbl (cdr tbl)))))
|
||||
((equal e '(:grouptags)) (insert " : "))
|
||||
(t
|
||||
(setq tg (copy-sequence (car e)) c2 nil)
|
||||
(if (cdr e)
|
||||
(setq c (cdr e))
|
||||
;; automatically assign a character.
|
||||
(setq c1 (string-to-char
|
||||
(downcase (substring
|
||||
tg (if (= (string-to-char tg) ?@) 1 0)))))
|
||||
(if (or (rassoc c1 ntable) (rassoc c1 table))
|
||||
(while (or (rassoc char ntable) (rassoc char table))
|
||||
(setq char (1+ char)))
|
||||
(setq c2 c1))
|
||||
(setq c (or c2 char)))
|
||||
(when ingroup (push tg (car groups)))
|
||||
(setq tg (org-add-props tg nil 'face
|
||||
(cond
|
||||
((not (assoc tg table))
|
||||
(org-get-todo-face tg))
|
||||
((member tg current) c-face)
|
||||
((member tg inherited) i-face))))
|
||||
(when (equal (caar tbl) :grouptags)
|
||||
(org-add-props tg nil 'face 'org-tag-group))
|
||||
(when (and (zerop cnt) (not ingroup) (not intaggroup)) (insert " "))
|
||||
(insert "[" c "] " tg (make-string
|
||||
(- fwidth 4 (length tg)) ?\ ))
|
||||
(push (cons tg c) ntable)
|
||||
(when (= (cl-incf cnt) ncol)
|
||||
(unless (memq (caar tbl) '(:endgroup :endgrouptag))
|
||||
(insert "\n")
|
||||
(when (or ingroup intaggroup) (insert " ")))
|
||||
(setq cnt 0)))))
|
||||
(setq ntable (nreverse ntable))
|
||||
(insert "\n")
|
||||
(goto-char (point-min))
|
||||
(unless expert (org-fit-window-to-buffer))
|
||||
(setq rtn
|
||||
(catch 'exit
|
||||
(while t
|
||||
(message "[a-z..]:toggle [SPC]:clear [RET]:accept [TAB]:edit [!] %sgroups%s"
|
||||
(if (not groups) "no " "")
|
||||
(if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi")))
|
||||
(setq c (let ((inhibit-quit t)) (read-char-exclusive)))
|
||||
(setq org-last-tag-selection-key c)
|
||||
(cond
|
||||
((= c ?\r) (throw 'exit t))
|
||||
((= c ?!)
|
||||
(setq groups (not groups))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "[{}]" nil t) (replace-match " ")))
|
||||
((= c ?\C-c)
|
||||
(if (not expert)
|
||||
(org-fast-tag-show-exit
|
||||
(setq exit-after-next (not exit-after-next)))
|
||||
(setq expert nil)
|
||||
(delete-other-windows)
|
||||
(set-window-buffer (split-window-vertically) " *Org tags*")
|
||||
(org-switch-to-buffer-other-window " *Org tags*")
|
||||
(org-fit-window-to-buffer)))
|
||||
((or (= c ?\C-g)
|
||||
(and (= c ?q) (not (rassoc c ntable))))
|
||||
(delete-overlay org-tags-overlay)
|
||||
(setq quit-flag t))
|
||||
((= c ?\ )
|
||||
(setq current nil)
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
((= c ?\t)
|
||||
(condition-case nil
|
||||
(setq tg (completing-read
|
||||
"Tag: "
|
||||
(or buffer-tags
|
||||
(with-current-buffer buf
|
||||
(setq buffer-tags
|
||||
(org-get-buffer-tags))))))
|
||||
(quit (setq tg "")))
|
||||
(when (string-match "\\S-" tg)
|
||||
(cl-pushnew (list tg) buffer-tags :test #'equal)
|
||||
(setq e (car tbl))
|
||||
(while (equal (car tbl) '(:newline))
|
||||
(insert "\n")
|
||||
(setq tbl (cdr tbl)))))
|
||||
((equal e '(:grouptags)) (insert " : "))
|
||||
(t
|
||||
(setq tg (copy-sequence (car e)) c2 nil)
|
||||
(if (cdr e)
|
||||
(setq c (cdr e))
|
||||
;; automatically assign a character.
|
||||
(setq c1 (string-to-char
|
||||
(downcase (substring
|
||||
tg (if (= (string-to-char tg) ?@) 1 0)))))
|
||||
(if (or (rassoc c1 ntable) (rassoc c1 table))
|
||||
(while (or (rassoc char ntable) (rassoc char table))
|
||||
(setq char (1+ char)))
|
||||
(setq c2 c1))
|
||||
(setq c (or c2 char)))
|
||||
(when ingroup (push tg (car groups)))
|
||||
(setq tg (org-add-props tg nil 'face
|
||||
(cond
|
||||
((not (assoc tg table))
|
||||
(org-get-todo-face tg))
|
||||
((member tg current) c-face)
|
||||
((member tg inherited) i-face))))
|
||||
(when (equal (caar tbl) :grouptags)
|
||||
(org-add-props tg nil 'face 'org-tag-group))
|
||||
(when (and (zerop cnt) (not ingroup) (not intaggroup)) (insert " "))
|
||||
(insert "[" c "] " tg (make-string
|
||||
(- fwidth 4 (length tg)) ?\ ))
|
||||
(push (cons tg c) ntable)
|
||||
(when (= (cl-incf cnt) ncol)
|
||||
(unless (memq (caar tbl) '(:endgroup :endgrouptag))
|
||||
(insert "\n")
|
||||
(when (or ingroup intaggroup) (insert " ")))
|
||||
(setq cnt 0)))))
|
||||
(setq ntable (nreverse ntable))
|
||||
(insert "\n")
|
||||
(goto-char (point-min))
|
||||
(unless expert (org-fit-window-to-buffer))
|
||||
(setq rtn
|
||||
(catch 'exit
|
||||
(while t
|
||||
(message "[a-z..]:toggle [SPC]:clear [RET]:accept [TAB]:edit [!] %sgroups%s"
|
||||
(if (not groups) "no " "")
|
||||
(if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi")))
|
||||
(setq c (let ((inhibit-quit t)) (read-char-exclusive)))
|
||||
(setq org-last-tag-selection-key c)
|
||||
(cond
|
||||
((= c ?\r) (throw 'exit t))
|
||||
((= c ?!)
|
||||
(setq groups (not groups))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "[{}]" nil t) (replace-match " ")))
|
||||
((= c ?\C-c)
|
||||
(if (not expert)
|
||||
(org-fast-tag-show-exit
|
||||
(setq exit-after-next (not exit-after-next)))
|
||||
(setq expert nil)
|
||||
(delete-other-windows)
|
||||
(set-window-buffer (split-window-vertically) " *Org tags*")
|
||||
(org-switch-to-buffer-other-window " *Org tags*")
|
||||
(org-fit-window-to-buffer)))
|
||||
((or (= c ?\C-g)
|
||||
(and (= c ?q) (not (rassoc c ntable))))
|
||||
(delete-overlay org-tags-overlay)
|
||||
(setq quit-flag t))
|
||||
((= c ?\ )
|
||||
(setq current nil)
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
((= c ?\t)
|
||||
(condition-case nil
|
||||
(setq tg (completing-read
|
||||
"Tag: "
|
||||
(or buffer-tags
|
||||
(with-current-buffer buf
|
||||
(setq buffer-tags
|
||||
(org-get-buffer-tags))))))
|
||||
(quit (setq tg "")))
|
||||
(when (string-match "\\S-" tg)
|
||||
(cl-pushnew (list tg) buffer-tags :test #'equal)
|
||||
(if (member tg current)
|
||||
(setq current (delete tg current))
|
||||
(push tg current)))
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
((setq e (rassoc c todo-table) tg (car e))
|
||||
(with-current-buffer buf
|
||||
(save-excursion (org-todo tg)))
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
((setq e (rassoc c ntable) tg (car e))
|
||||
(if (member tg current)
|
||||
(setq current (delete tg current))
|
||||
(push tg current)))
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
((setq e (rassoc c todo-table) tg (car e))
|
||||
(with-current-buffer buf
|
||||
(save-excursion (org-todo tg)))
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
((setq e (rassoc c ntable) tg (car e))
|
||||
(if (member tg current)
|
||||
(setq current (delete tg current))
|
||||
(cl-loop for g in groups do
|
||||
(when (member tg g)
|
||||
(dolist (x g) (setq current (delete x current)))))
|
||||
(push tg current))
|
||||
(when exit-after-next (setq exit-after-next 'now))))
|
||||
(cl-loop for g in groups do
|
||||
(when (member tg g)
|
||||
(dolist (x g) (setq current (delete x current)))))
|
||||
(push tg current))
|
||||
(when exit-after-next (setq exit-after-next 'now))))
|
||||
|
||||
;; Create a sorted list
|
||||
(setq current
|
||||
(sort current
|
||||
(lambda (a b)
|
||||
(assoc b (cdr (memq (assoc a ntable) ntable))))))
|
||||
(when (eq exit-after-next 'now) (throw 'exit t))
|
||||
(goto-char (point-min))
|
||||
(beginning-of-line 2)
|
||||
(delete-region (point) (point-at-eol))
|
||||
(org-fast-tag-insert "Current" current c-face)
|
||||
(org-set-current-tags-overlay current ov-prefix)
|
||||
(let ((tag-re (concat "\\[.\\] \\(" org-tag-re "\\)")))
|
||||
(while (re-search-forward tag-re nil t)
|
||||
(let ((tag (match-string 1)))
|
||||
(add-text-properties
|
||||
(match-beginning 1) (match-end 1)
|
||||
(list 'face
|
||||
(cond
|
||||
((member tag current) c-face)
|
||||
((member tag inherited) i-face)
|
||||
(t (get-text-property (match-beginning 1) '
|
||||
face))))))))
|
||||
(goto-char (point-min)))))
|
||||
(delete-overlay org-tags-overlay)
|
||||
(if rtn
|
||||
(mapconcat 'identity current ":")
|
||||
nil))))
|
||||
;; Create a sorted list
|
||||
(setq current
|
||||
(sort current
|
||||
(lambda (a b)
|
||||
(assoc b (cdr (memq (assoc a ntable) ntable))))))
|
||||
(when (eq exit-after-next 'now) (throw 'exit t))
|
||||
(goto-char (point-min))
|
||||
(beginning-of-line 2)
|
||||
(delete-region (point) (point-at-eol))
|
||||
(org-fast-tag-insert "Current" current c-face)
|
||||
(org-set-current-tags-overlay current ov-prefix)
|
||||
(let ((tag-re (concat "\\[.\\] \\(" org-tag-re "\\)")))
|
||||
(while (re-search-forward tag-re nil t)
|
||||
(let ((tag (match-string 1)))
|
||||
(add-text-properties
|
||||
(match-beginning 1) (match-end 1)
|
||||
(list 'face
|
||||
(cond
|
||||
((member tag current) c-face)
|
||||
((member tag inherited) i-face)
|
||||
(t (get-text-property (match-beginning 1) '
|
||||
face))))))))
|
||||
(goto-char (point-min)))))
|
||||
(delete-overlay org-tags-overlay)
|
||||
(if rtn
|
||||
(mapconcat 'identity current ":")
|
||||
nil)))))
|
||||
|
||||
(defun org-make-tag-string (tags)
|
||||
"Return string associated to TAGS.
|
||||
|
|
|
|||
Loading…
Reference in a new issue