emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
* [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

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).