Here is my patch, which works for my use case. Although the commit only changes a couple of lines, there are large blocks whose indentation changes. The non-whitespace changes are 1) to add a without-restriction as soon as buffer switches to archive buffer. 2) to wrap the call to org-fold-show-all in that buffer with an org-fold-core-save-visibility 3) Delete a call to widen, which had become redundant.
The function org-archive-subtree is quite long, but I believe I put the two wrappers in the sensible place, without breaking anything. Ihor, I don't quite understand your remark about the two previous patches, are they something I need to take into account in this patch? Best, Benjamin On Sat, Jul 19, 2025 at 11:41 PM Ihor Radchenko <yanta...@posteo.net> wrote: > Benjamin McMillan <mcmilla...@gmail.com> writes: > > > When archiving a subtree to a different heading in the same buffer, all > > headings are unfolded and the current narrowing is lost. This is easily > > reproduced in a minimal instance of emacs by the following steps: > > > > 1. In an org file, create two headings "head" and "arch". Create a > "child" > > heading for "head". > > 2. Add the archive property to "head" > > :PROPERTIES: > > #+ARCHIVE: ::* arch > > :END: > > 3. org-narrow-to-subtree on "head". > > 4. org-archive-subtree on "child" > > 5. (This demonstrates the loss of narrowing, you can also create > additional > > headings with folded content to see the loss of folding.) > > Confirmed. This kind of intentional, but intentional in a sense that it > was a (non-ideal) implementation detail of previous feature additions > and bug fixes: > > https://cgit.git.savannah.gnu.org/cgit/emacs/org-mode.git/commit/?id=44e7ed1a59c8587c2d5c3a54917576f1505a6c7b > > https://cgit.git.savannah.gnu.org/cgit/emacs/org-mode.git/commit/?id=bf09955fec57307616926959b31e19af42520db0 > > > Both issues can be fixed by small modification to org-archive-subtree, by > > wrapping the archiving edits in org-fold-core-save-visibility and > > save-excursion blocks. > > > > I am happy to submit a patch. > > That would be welcome. > > -- > Ihor Radchenko // yantar92, > Org mode maintainer, > 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> >
From 02fe8d7de38bf43351826afbea2b1d429f88780e Mon Sep 17 00:00:00 2001 From: Benjamin McMillan <mcmillanbb@gmail.com> Date: Mon, 21 Jul 2025 21:41:46 +0900 Subject: [PATCH] org-archive.el: Fix issue archiving subtree to same file * org-archive.el (org-archive-subtree): Fixes an issue where archiving a subtree to the same file would lose both folding and narrowing state, by adding without-restriction and org-fold-core-save-visibility wrappers. Reported-by: Benjamin McMillan <mcmillanbb@gmail.com> Link: https://list.orgmode.org/87h5z8p7l5.fsf@localhost/T/#t --- lisp/org-archive.el | 195 ++++++++++++++++++++++---------------------- 1 file changed, 98 insertions(+), 97 deletions(-) diff --git a/lisp/org-archive.el b/lisp/org-archive.el index fb386e683..e36d1ca48 100644 --- a/lisp/org-archive.el +++ b/lisp/org-archive.el @@ -324,104 +324,105 @@ direct children of this heading." ;; 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-fold-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 - (org-fold-show-subtree) + (without-restriction + ;; 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-fold-core-save-visibility t + (org-fold-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 + (org-fold-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 - (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)))) - (run-hooks 'org-archive-finalize-hook) - ;; 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)))) + (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)))) + (run-hooks 'org-archive-finalize-hook) + ;; 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)))))))) ;; Here we are back in the original buffer. Everything seems ;; to have worked. So now run hooks, cut the tree and finish ;; up. -- 2.50.1
