From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp11.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id F6f+Ih122mETawAAgWs5BA (envelope-from ) for ; Sun, 09 Jan 2022 06:43:57 +0100 Received: from aspmx1.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp11.migadu.com with LMTPS id 6IGoHx122mHs9wAA9RJhRA (envelope-from ) for ; Sun, 09 Jan 2022 06:43:57 +0100 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 98ABA23038 for ; Sun, 9 Jan 2022 06:43:56 +0100 (CET) Received: from localhost ([::1]:54554 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1n6Qzj-0007yQ-Ix for larch@yhetil.org; Sun, 09 Jan 2022 00:43:55 -0500 Received: from eggs.gnu.org ([209.51.188.92]:33658) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n6Qyi-0007yG-Gd for emacs-orgmode@gnu.org; Sun, 09 Jan 2022 00:42:53 -0500 Received: from [2607:f8b0:4864:20::630] (port=39679 helo=mail-pl1-x630.google.com) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1n6Qyf-0003IS-Lz for emacs-orgmode@gnu.org; Sun, 09 Jan 2022 00:42:52 -0500 Received: by mail-pl1-x630.google.com with SMTP id l8so7207864plt.6 for ; Sat, 08 Jan 2022 21:42:48 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=from:to:subject:date:message-id:mime-version; bh=v+csWDYaqS2vIexyHK69Zxs0YkRBz4yyjn8IKTFBp7E=; b=l2LGss5P9B/7P8H63OWtzJvoFJsmCENYX/jl1yF50oQBGwTRONAC8AKFoPx75DKGLT BEUSOx69t6/HKqo7z+ggwV+Pli5Sqjbnu6/wHW6ciwFK1VtxHXrrdErxR7SaK70GX9T/ YEdRcRogX8Uo4GcicNa9hn/fJoYqeNCX/MteunzVHTxRTdaF379X4fA/e5lTnLQzs1RA IsEKxJeaoghaUcrm2E62XsD920OwyXxrCDf1p9v4yI8TGY4JB1HkRgXIB5WEGUXeb2HY huz1plHspo8IkYzxJaybwIDDr6V046cLfF/KIkZMQqlTUuLEWgu1/rIGek/qpvGySsb7 Cv3w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:to:subject:date:message-id:mime-version; bh=v+csWDYaqS2vIexyHK69Zxs0YkRBz4yyjn8IKTFBp7E=; b=0RjEDN6QmseAYHoBevzLJBgvj0gIXCD+x/AxtFuonZRFA6i9D2RdkwWxDjaUB1XocM OYRAbkq9CtwJQa+ZJQ4zPTAiwoTUdgvX7VphETfVXyzo9m0JiRTV3gi6/AAjreFiRihc bNy6XbmhUsj7+DRndCh+H0lEyhB5M5Ql8K7V+sQST1DTYA1DwHURO1NQlq5rBJuzLtBi d1iuBSo7HkzB8SrKmUXqKwrx4WxFDHaYlltrbpPKHnw0wl2kR/I5LUb7ICwWo1bwVn6A WNfRUkHdadDWn+Ybd7IYEOEI1J/oKUpFrA3rx/mVORBa89UXIYyFlN+z+ZGCeqTiIuCR bFpQ== X-Gm-Message-State: AOAM5330WvkvpGkeAcIx0AIAbnKoVgpq7eT/McpiKitIpUzSyFzYCRoH rMf5r3QyKrSvt+O8QeyIKXeGP7ZSlpT7zg== X-Google-Smtp-Source: ABdhPJzfJyh7yNkSXGcC3oo7DnjG080H+RPolFWcJ/xgz5ud2MFSGH4ZpmEjgMBFOwmFZ8B8+KegCg== X-Received: by 2002:a17:90b:3889:: with SMTP id mu9mr23904430pjb.215.1641706967158; Sat, 08 Jan 2022 21:42:47 -0800 (PST) Received: from thinkpad-x1.gmail.com ([2601:646:103:34b0:f55c:b1d3:aa18:7ae1]) by smtp.gmail.com with ESMTPSA id t21sm4403820pjq.9.2022.01.08.21.42.46 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 08 Jan 2022 21:42:46 -0800 (PST) From: Ankit Raj Pandey To: emacs-orgmode@gnu.org Subject: [PATCH] Prevent blocked tasks from being archived Date: Sat, 08 Jan 2022 21:42:45 -0800 Message-ID: <86a6g5jwh6.fsf@smtp.gmail.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Host-Lookup-Failed: Reverse DNS lookup failed for 2607:f8b0:4864:20::630 (failed) Received-SPF: pass client-ip=2607:f8b0:4864:20::630; envelope-from=arpandeytest@gmail.com; helo=mail-pl1-x630.google.com X-Spam_score_int: -12 X-Spam_score: -1.3 X-Spam_bar: - X-Spam_report: (-1.3 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, RDNS_NONE=0.793, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=no autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-orgmode@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+larch=yhetil.org@gnu.org Sender: "Emacs-orgmode" X-Migadu-Flow: FLOW_IN X-Migadu-Country: US ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1641707036; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:mime-version:mime-version: content-type:content-type:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=v+csWDYaqS2vIexyHK69Zxs0YkRBz4yyjn8IKTFBp7E=; b=ImICfbN/iD4H1hbzXpeA6ouhCXun1LShLMAuw7QrqrgLvPhwPjr2OTM+sRqh+CVOVfz40U xA+CbpaRvzi2LktWtrhmYB6SAnC1NIk/XlqpkCP0m2dnSDOy3WNP0e09hJQXhfz2dkzdoS WF08r9l9TJMosfFgfim7D5NXBVU27WGQLc9/Ds60MHdVIt7hROVQiqWGQu81ed4MYYl6gQ xnq5tyDYg2A7YQXsc2kNDYQ/CSch59DuBFQbbL3S6ujHqCiS57vVXJMLA/xs5YH1UMNHXx YoG0hv1KTdMZboA32wWXQjPIY8HX5M0Hj7SgzcXDDtGzgBeS1iFL+yV/jFYShw== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1641707036; a=rsa-sha256; cv=none; b=A2Cr6oQWFkDnFQefBOIpTH6stNjEW6MhVj99HbpU32Iv1dBKX5cZu1WbeYbitPKat1JE7u SJAZNMy4s4u1diXykmEkGeE8914KbCaL2peyE7GgYz3ktbyN6FIr6oF5X1thNDELqgqr8/ rlPAGbjsY+rct+K7WLlwTUFuIRKoIMo7BAB9eHsZ40EzWLG2U6x6hiUM57Q/IGj9dU2mYl eXk4XKnhSNzthKUPwfrCoLX78floPtzcfHmjQvI3hPWgFqhkOb3QizF8YOQ0l8G8lz1LM7 ifJ3EtGCRNQlx92OjyEcNPXlLNPvsBr9ngyPedABva7u1nWQNN0JvYz+elbc6A== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=pass header.d=gmail.com header.s=20210112 header.b=l2LGss5P; dmarc=pass (policy=none) header.from=gmail.com; spf=pass (aspmx1.migadu.com: domain of "emacs-orgmode-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="emacs-orgmode-bounces+larch=yhetil.org@gnu.org" X-Migadu-Spam-Score: -4.31 Authentication-Results: aspmx1.migadu.com; dkim=pass header.d=gmail.com header.s=20210112 header.b=l2LGss5P; dmarc=pass (policy=none) header.from=gmail.com; spf=pass (aspmx1.migadu.com: domain of "emacs-orgmode-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="emacs-orgmode-bounces+larch=yhetil.org@gnu.org" X-Migadu-Queue-Id: 98ABA23038 X-Spam-Score: -4.31 X-Migadu-Scanner: scn1.migadu.com X-TUID: 2C+u6a0TUTBT --=-=-= Content-Type: text/plain 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-org-archive.el-Prevent-archiving-of-blocked-tasks.patch >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 --=-=-=--