From fea8941ef13fc3e9cab8b0a69675578b2ee1f611 Mon Sep 17 00:00:00 2001 From: Ankit Pandey Date: Mon, 3 Jan 2022 17:41:49 -0800 Subject: [PATCH] org-archive.el: Prevent archiving of blocked tasks * lisp/org-archive.el (org-archive-subtree): Mark the entry as DONE before it's copied to the destination. The original TODO info is still preserved in the context. * lisp/org.el (org-todo): Return t if the entry was changed successfully, and nil if the change failed. --- lisp/org-archive.el | 417 ++++++++++++++++++++++---------------------- lisp/org.el | 7 +- 2 files changed, 216 insertions(+), 208 deletions(-) diff --git a/lisp/org-archive.el b/lisp/org-archive.el index 8b4547a64..202e50f99 100644 --- a/lisp/org-archive.el +++ b/lisp/org-archive.el @@ -214,212 +214,217 @@ cursor is not at a headline when these commands are called, try all level 1 trees. If the cursor is on a headline, only try the direct children of this heading." (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 - `(progn (setq org-map-continue-from (progn (org-back-to-heading) (point))) - (org-archive-subtree ,find-done)) - org-loop-over-headlines-in-active-region - cl (if (org-invisible-p) (org-end-of-subtree nil t)))) - (cond - ((equal find-done '(4)) (org-archive-all-done)) - ((equal find-done '(16)) (org-archive-all-old)) - (t - ;; Save all relevant TODO keyword-related variables. - (let* ((tr-org-todo-keywords-1 org-todo-keywords-1) - (tr-org-todo-kwd-alist org-todo-kwd-alist) - (tr-org-done-keywords org-done-keywords) - (tr-org-todo-regexp org-todo-regexp) - (tr-org-todo-line-regexp org-todo-line-regexp) - (tr-org-odd-levels-only org-odd-levels-only) - (this-buffer (current-buffer)) - (time (format-time-string - (substring (cdr org-time-stamp-formats) 1 -1))) - (file (abbreviate-file-name - (or (buffer-file-name (buffer-base-buffer)) - (error "No file associated to buffer")))) - (location (org-archive--compute-location - (or (org-entry-get nil "ARCHIVE" 'inherit) - org-archive-location))) - (afile (car location)) - (heading (cdr location)) - (infile-p (equal file (abbreviate-file-name (or afile "")))) - (newfile-p (and (org-string-nw-p afile) - (not (file-exists-p afile)))) - (buffer (cond ((not (org-string-nw-p afile)) this-buffer) - ((find-buffer-visiting afile)) - ((find-file-noselect afile)) - (t (error "Cannot access file \"%s\"" afile)))) - (org-odd-levels-only - (if (local-variable-p 'org-odd-levels-only (current-buffer)) - org-odd-levels-only - tr-org-odd-levels-only)) - level datetree-date datetree-subheading-p - ;; Suppress on-the-fly headline updates. - (org-element--cache-avoid-synchronous-headline-re-parsing t)) - (when (string-match "\\`datetree/\\(\\**\\)" heading) - ;; "datetree/" corresponds to 3 levels of headings. - (let ((nsub (length (match-string 1 heading)))) - (setq heading (concat (make-string - (+ (if org-odd-levels-only 5 3) - (* (org-level-increment) nsub)) - ?*) - (substring heading (match-end 0)))) - (setq datetree-subheading-p (> nsub 0))) - (setq datetree-date (org-date-to-gregorian - (or (org-entry-get nil "CLOSED" t) time)))) - (if (and (> (length heading) 0) - (string-match "^\\*+" heading)) - (setq level (match-end 0)) - (setq heading nil level 0)) - (save-excursion - (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)) - (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) - (itags . ,(mapconcat #'identity inherited-tags " ")) - (ltags . ,(mapconcat #'identity local-tags " ")) - (olpath . ,(mapconcat #'identity - (org-get-outline-path) - "/")) - (time . ,time) - (todo . ,(org-entry-get (point) "TODO"))))) - ;; We first only copy, in case something goes wrong - ;; we need to protect `this-command', to avoid kill-region sets it, - ;; which would lead to duplication of subtrees - (let (this-command) (org-copy-subtree 1 nil t)) - (set-buffer buffer) - ;; Enforce Org mode for the archive buffer - (if (not (derived-mode-p 'org-mode)) - ;; Force the mode for future visits. - (let ((org-insert-mode-line-in-empty-file t) - (org-inhibit-startup t)) - (call-interactively 'org-mode))) - (when (and newfile-p org-archive-file-header-format) - (goto-char (point-max)) - (insert (format org-archive-file-header-format - (buffer-file-name this-buffer)))) - (when datetree-date - (require 'org-datetree) - (org-datetree-find-date-create datetree-date) - (org-narrow-to-subtree)) - ;; Force the TODO keywords of the original buffer - (let ((org-todo-line-regexp tr-org-todo-line-regexp) - (org-todo-keywords-1 tr-org-todo-keywords-1) - (org-todo-kwd-alist tr-org-todo-kwd-alist) - (org-done-keywords tr-org-done-keywords) - (org-todo-regexp tr-org-todo-regexp) - (org-todo-line-regexp tr-org-todo-line-regexp)) - (goto-char (point-min)) - (org-show-all '(headings blocks)) - (if (and heading (not (and datetree-date (not datetree-subheading-p)))) - (progn - (if (re-search-forward - (concat "^" (regexp-quote heading) - "\\([ \t]+:\\(" org-tag-re ":\\)+\\)?[ \t]*$") - nil t) - (goto-char (match-end 0)) - ;; Heading not found, just insert it at the end - (goto-char (point-max)) - (or (bolp) (insert "\n")) - ;; datetrees don't need too much spacing - (insert (if datetree-date "" "\n") heading "\n") - (end-of-line 0)) - ;; Make the subtree visible - (outline-show-subtree) - (if org-archive-reversed-order - (progn - (org-back-to-heading t) - (outline-next-heading)) - (org-end-of-subtree t)) - (skip-chars-backward " \t\r\n") - (and (looking-at "[ \t\r\n]*") - ;; datetree archives don't need so much spacing. - (replace-match (if datetree-date "\n" "\n\n")))) - ;; No specific heading, just go to end of file, or to the - ;; beginning, depending on `org-archive-reversed-order'. - (if org-archive-reversed-order - (progn - (goto-char (point-min)) - (unless (org-at-heading-p) (outline-next-heading))) - (goto-char (point-max)) - ;; Subtree narrowing can let the buffer end on - ;; a headline. `org-paste-subtree' then deletes it. - ;; To prevent this, make sure visible part of buffer - ;; always terminates on a new line, while limiting - ;; number of blank lines in a date tree. - (unless (and datetree-date (bolp)) (insert "\n")))) - ;; Paste - (org-paste-subtree (org-get-valid-level level (and heading 1))) - ;; Shall we append inherited tags? - (and inherited-tags - (or (and (eq org-archive-subtree-add-inherited-tags 'infile) - infile-p) - (eq org-archive-subtree-add-inherited-tags t)) - (org-set-tags all-tags)) - ;; Mark the entry as done - (when (and org-archive-mark-done - (let ((case-fold-search nil)) - (looking-at org-todo-line-regexp)) - (or (not (match-end 2)) - (not (member (match-string 2) org-done-keywords)))) - (let (org-log-done org-todo-log-states) - (org-todo - (car (or (member org-archive-mark-done org-done-keywords) - org-done-keywords))))) - - ;; Add the context info. - (dolist (item org-archive-save-context-info) - (let ((value (cdr (assq item context)))) - (when (org-string-nw-p value) - (org-entry-put - (point) - (concat "ARCHIVE_" (upcase (symbol-name item))) - value)))) - ;; Save the buffer, if it is not the same buffer and - ;; depending on `org-archive-subtree-save-file-p'. - (unless (eq this-buffer buffer) - (when (or (eq org-archive-subtree-save-file-p t) - (eq org-archive-subtree-save-file-p - (if (boundp 'org-archive-from-agenda) - 'from-agenda - 'from-org))) - (save-buffer))) - (widen)))) - ;; Here we are back in the original buffer. Everything seems - ;; to have worked. So now run hooks, cut the tree and finish - ;; up. - (run-hooks 'org-archive-hook) - (let (this-command) (org-cut-subtree)) - (when (featurep 'org-inlinetask) - (org-inlinetask-remove-END-maybe)) - (setq org-markers-to-move nil) - (when org-provide-todo-statistics - (save-excursion - ;; Go to parent, even if no children exist. - (org-up-heading-safe) - ;; Update cookie of parent. - (org-update-statistics-cookies nil))) - (message "Subtree archived %s" - (if (eq this-buffer buffer) - (concat "under heading: " heading) - (concat "in file: " (abbreviate-file-name afile))))))) - (org-reveal) - (if (looking-at "^[ \t]*$") - (outline-next-visible-heading 1)))) + (catch 'abort + (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 + `(progn (setq org-map-continue-from (progn (org-back-to-heading) (point))) + (org-archive-subtree ,find-done)) + org-loop-over-headlines-in-active-region + cl (if (org-invisible-p) (org-end-of-subtree nil t)))) + (cond + ((equal find-done '(4)) (org-archive-all-done)) + ((equal find-done '(16)) (org-archive-all-old)) + (t + ;; Save all relevant TODO keyword-related variables. + (let* ((tr-org-todo-keywords-1 org-todo-keywords-1) + (tr-org-todo-kwd-alist org-todo-kwd-alist) + (tr-org-done-keywords org-done-keywords) + (tr-org-todo-regexp org-todo-regexp) + (tr-org-todo-line-regexp org-todo-line-regexp) + (tr-org-odd-levels-only org-odd-levels-only) + (this-buffer (current-buffer)) + (time (format-time-string + (substring (cdr org-time-stamp-formats) 1 -1))) + (file (abbreviate-file-name + (or (buffer-file-name (buffer-base-buffer)) + (error "No file associated to buffer")))) + (location (org-archive--compute-location + (or (org-entry-get nil "ARCHIVE" 'inherit) + org-archive-location))) + (afile (car location)) + (heading (cdr location)) + (infile-p (equal file (abbreviate-file-name (or afile "")))) + (newfile-p (and (org-string-nw-p afile) + (not (file-exists-p afile)))) + (buffer (cond ((not (org-string-nw-p afile)) this-buffer) + ((find-buffer-visiting afile)) + ((find-file-noselect afile)) + (t (error "Cannot access file \"%s\"" afile)))) + (org-odd-levels-only + (if (local-variable-p 'org-odd-levels-only (current-buffer)) + org-odd-levels-only + tr-org-odd-levels-only)) + level datetree-date datetree-subheading-p + ;; Suppress on-the-fly headline updates. + (org-element--cache-avoid-synchronous-headline-re-parsing t)) + (when (string-match "\\`datetree/\\(\\**\\)" heading) + ;; "datetree/" corresponds to 3 levels of headings. + (let ((nsub (length (match-string 1 heading)))) + (setq heading (concat (make-string + (+ (if org-odd-levels-only 5 3) + (* (org-level-increment) nsub)) + ?*) + (substring heading (match-end 0)))) + (setq datetree-subheading-p (> nsub 0))) + (setq datetree-date (org-date-to-gregorian + (or (org-entry-get nil "CLOSED" t) time)))) + (if (and (> (length heading) 0) + (string-match "^\\*+" heading)) + (setq level (match-end 0)) + (setq heading nil level 0)) + (save-excursion + (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)) + (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) + (itags . ,(mapconcat #'identity inherited-tags " ")) + (ltags . ,(mapconcat #'identity local-tags " ")) + (olpath . ,(mapconcat #'identity + (org-get-outline-path) + "/")) + (time . ,time) + (todo . ,(org-entry-get (point) "TODO"))))) + + ;; Mark the entry as done. Abort the archive process if + ;; changing the todo state was blocked. + (when (and org-archive-mark-done + (let ((case-fold-search nil)) + (looking-at org-todo-line-regexp)) + (or (not (match-end 2)) + (not (member (match-string 2) org-done-keywords)))) + (let (org-log-done org-todo-log-states) + (when (not (org-todo + (car (or (member org-archive-mark-done org-done-keywords) + org-done-keywords)))) + (throw 'abort nil)))) + + ;; We first only copy, in case something goes wrong + ;; we need to protect `this-command', to avoid kill-region sets it, + ;; which would lead to duplication of subtrees + (let (this-command) (org-copy-subtree 1 nil t)) + (set-buffer buffer) + ;; Enforce Org mode for the archive buffer + (if (not (derived-mode-p 'org-mode)) + ;; Force the mode for future visits. + (let ((org-insert-mode-line-in-empty-file t) + (org-inhibit-startup t)) + (call-interactively 'org-mode))) + (when (and newfile-p org-archive-file-header-format) + (goto-char (point-max)) + (insert (format org-archive-file-header-format + (buffer-file-name this-buffer)))) + (when datetree-date + (require 'org-datetree) + (org-datetree-find-date-create datetree-date) + (org-narrow-to-subtree)) + ;; Force the TODO keywords of the original buffer + (let ((org-todo-line-regexp tr-org-todo-line-regexp) + (org-todo-keywords-1 tr-org-todo-keywords-1) + (org-todo-kwd-alist tr-org-todo-kwd-alist) + (org-done-keywords tr-org-done-keywords) + (org-todo-regexp tr-org-todo-regexp) + (org-todo-line-regexp tr-org-todo-line-regexp)) + (goto-char (point-min)) + (org-show-all '(headings blocks)) + (if (and heading (not (and datetree-date (not datetree-subheading-p)))) + (progn + (if (re-search-forward + (concat "^" (regexp-quote heading) + "\\([ \t]+:\\(" org-tag-re ":\\)+\\)?[ \t]*$") + nil t) + (goto-char (match-end 0)) + ;; Heading not found, just insert it at the end + (goto-char (point-max)) + (or (bolp) (insert "\n")) + ;; datetrees don't need too much spacing + (insert (if datetree-date "" "\n") heading "\n") + (end-of-line 0)) + ;; Make the subtree visible + (outline-show-subtree) + (if org-archive-reversed-order + (progn + (org-back-to-heading t) + (outline-next-heading)) + (org-end-of-subtree t)) + (skip-chars-backward " \t\r\n") + (and (looking-at "[ \t\r\n]*") + ;; datetree archives don't need so much spacing. + (replace-match (if datetree-date "\n" "\n\n")))) + ;; No specific heading, just go to end of file, or to the + ;; beginning, depending on `org-archive-reversed-order'. + (if org-archive-reversed-order + (progn + (goto-char (point-min)) + (unless (org-at-heading-p) (outline-next-heading))) + (goto-char (point-max)) + ;; Subtree narrowing can let the buffer end on + ;; a headline. `org-paste-subtree' then deletes it. + ;; To prevent this, make sure visible part of buffer + ;; always terminates on a new line, while limiting + ;; number of blank lines in a date tree. + (unless (and datetree-date (bolp)) (insert "\n")))) + ;; Paste + (org-paste-subtree (org-get-valid-level level (and heading 1))) + ;; Shall we append inherited tags? + (and inherited-tags + (or (and (eq org-archive-subtree-add-inherited-tags 'infile) + infile-p) + (eq org-archive-subtree-add-inherited-tags t)) + (org-set-tags all-tags)) + + ;; Add the context info. + (dolist (item org-archive-save-context-info) + (let ((value (cdr (assq item context)))) + (when (org-string-nw-p value) + (org-entry-put + (point) + (concat "ARCHIVE_" (upcase (symbol-name item))) + value)))) + ;; Save the buffer, if it is not the same buffer and + ;; depending on `org-archive-subtree-save-file-p'. + (unless (eq this-buffer buffer) + (when (or (eq org-archive-subtree-save-file-p t) + (eq org-archive-subtree-save-file-p + (if (boundp 'org-archive-from-agenda) + 'from-agenda + 'from-org))) + (save-buffer))) + (widen)))) + ;; Here we are back in the original buffer. Everything seems + ;; to have worked. So now run hooks, cut the tree and finish + ;; up. + (run-hooks 'org-archive-hook) + (let (this-command) (org-cut-subtree)) + (when (featurep 'org-inlinetask) + (org-inlinetask-remove-END-maybe)) + (setq org-markers-to-move nil) + (when org-provide-todo-statistics + (save-excursion + ;; Go to parent, even if no children exist. + (org-up-heading-safe) + ;; Update cookie of parent. + (org-update-statistics-cookies nil))) + (message "Subtree archived %s" + (if (eq this-buffer buffer) + (concat "under heading: " heading) + (concat "in file: " (abbreviate-file-name afile))))))) + (org-reveal) + (if (looking-at "^[ \t]*$") + (outline-next-visible-heading 1))))) ;;;###autoload (defun org-archive-to-archive-sibling () diff --git a/lisp/org.el b/lisp/org.el index ce4e08eab..6f83d2152 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -9774,7 +9774,9 @@ When called through ELisp, arg is also interpreted in the following way: `nextset' -> switch to the next set of keywords `previousset' -> switch to the previous set of keywords \"WAITING\" -> switch to the specified keyword, but only if it - really is a member of `org-todo-keywords'." + really is a member of `org-todo-keywords'. + +Returns t if the change was successful, nil if it failed." (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) @@ -9978,7 +9980,8 @@ When called through ELisp, arg is also interpreted in the following way: (when org-trigger-hook (save-excursion (run-hook-with-args 'org-trigger-hook change-plist))) - (when commentp (org-toggle-comment)))))))) + (when commentp (org-toggle-comment))) + t))))) (defun org-block-todo-from-children-or-siblings-or-parent (change-plist) "Block turning an entry into a TODO, using the hierarchy. -- 2.34.1