Re: [PATCH] Prevent blocked tasks from being archived

[Ihor Radchenko]

Ankit Raj Pandey  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 .
Support Org development at ,
or support my work at 

[PATCH] Prevent blocked tasks from being archived

[Ankit Raj Pandey]

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

>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