* [PATCH] Prevent blocked tasks from being archived
@ 2022-01-09 5:42 Ankit Raj Pandey
2022-11-07 8:21 ` Ihor Radchenko
0 siblings, 1 reply; 2+ messages in thread
From: Ankit Raj Pandey @ 2022-01-09 5:42 UTC (permalink / raw)
To: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 364 bytes --]
Hi,
When org-archive-mark-done is enabled, org silently fails on setting the
TODO state of the archived headline to DONE if the task is blocked.
This patch changes that behavior so the headline is prevented from being
archived in the first place. Instead, org displays a message about why
the task is blocked (this message comes from org-todo).
Thanks,
Ankit
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-org-archive.el-Prevent-archiving-of-blocked-tasks.patch --]
[-- Type: text/x-patch, Size: 19590 bytes --]
From fea8941ef13fc3e9cab8b0a69675578b2ee1f611 Mon Sep 17 00:00:00 2001
From: Ankit Pandey <arpandeytest@gmail.com>
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
^ permalink raw reply related [flat|nested] 2+ messages in thread* Re: [PATCH] Prevent blocked tasks from being archived
2022-01-09 5:42 [PATCH] Prevent blocked tasks from being archived Ankit Raj Pandey
@ 2022-11-07 8:21 ` Ihor Radchenko
0 siblings, 0 replies; 2+ messages in thread
From: Ihor Radchenko @ 2022-11-07 8:21 UTC (permalink / raw)
To: Ankit Raj Pandey; +Cc: emacs-orgmode
Ankit Raj Pandey <arpandeytest@gmail.com> writes:
> When org-archive-mark-done is enabled, org silently fails on setting the
> TODO state of the archived headline to DONE if the task is blocked.
>
> This patch changes that behavior so the headline is prevented from being
> archived in the first place. Instead, org displays a message about why
> the task is blocked (this message comes from org-todo).
Thanks for the patch, and sorry for the late reply.
I see that you moved changing the todo state code before we switch to
the archive buffer. It is not safe. If something goes wrong during
archive process after changing the todo state, the todo will not be
recovered even though archiving fails.
--
Ihor Radchenko // yantar92,
Org mode contributor,
Learn more about Org mode at <https://orgmode.org/>.
Support Org development at <https://liberapay.com/org-mode>,
or support my work at <https://liberapay.com/yantar92>
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2022-11-07 8:22 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2022-01-09 5:42 [PATCH] Prevent blocked tasks from being archived Ankit Raj Pandey
2022-11-07 8:21 ` Ihor Radchenko
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).