From 361261b0489ead4bb3dc6cc30a1bf3878b0fffb7 Mon Sep 17 00:00:00 2001 From: Bastien Guerry Date: Fri, 30 Dec 2011 08:52:05 +0100 Subject: [PATCH 1/3] Allow to loop over active region for more archive commands. * org-archive.el (org-archive-subtree) (org-archive-to-archive-sibling, org-archive-set-tag) (org-toggle-archive-tag): Allow to loop over the active region by using `org-loop-over-headlines-in-active-region'. --- lisp/org-archive.el | 446 ++++++++++++++++++++++++-------------------- 1 file changed, 240 insertions(+), 206 deletions(-) diff --git a/lisp/org-archive.el b/lisp/org-archive.el index e42605580..9c0827a53 100644 --- a/lisp/org-archive.el +++ b/lisp/org-archive.el @@ -190,158 +190,165 @@ If the cursor is not at a headline when this command is called, try all level 1 trees. If the cursor is on a headline, only try the direct children of this heading." (interactive "P") - (if find-done - (org-archive-all-done) - ;; Save all relevant TODO keyword-relatex variables + (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) + (let (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 + 'region + (if (outline-invisible-p) (org-end-of-subtree nil t)))) + (if find-done + (org-archive-all-done) + ;; Save all relevant TODO keyword-relatex variables + (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler + (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)) + ;; start of variables that will be used for saving context + ;; The compiler complains about them - keep them anyway! + (file (abbreviate-file-name + (or (buffer-file-name (buffer-base-buffer)) + (error "No file associated to buffer")))) + (olpath (mapconcat 'identity (org-get-outline-path) "/")) + (time (format-time-string + (substring (cdr org-time-stamp-formats) 1 -1) + (current-time))) + category todo priority ltags itags atags + ;; end of variables that will be used for saving context + location afile heading buffer level newfile-p infile-p visiting) - (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler - (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)) - ;; start of variables that will be used for saving context - ;; The compiler complains about them - keep them anyway! - (file (abbreviate-file-name - (or (buffer-file-name (buffer-base-buffer)) - (error "No file associated to buffer")))) - (olpath (mapconcat 'identity (org-get-outline-path) "/")) - (time (format-time-string - (substring (cdr org-time-stamp-formats) 1 -1) - (current-time))) - category todo priority ltags itags atags - ;; end of variables that will be used for saving context - location afile heading buffer level newfile-p infile-p visiting) + ;; Find the local archive location + (setq location (org-get-local-archive-location) + afile (org-extract-archive-file location) + heading (org-extract-archive-heading location) + infile-p (equal file (abbreviate-file-name afile))) + (unless afile + (error "Invalid `org-archive-location'")) - ;; Find the local archive location - (setq location (org-get-local-archive-location) - afile (org-extract-archive-file location) - heading (org-extract-archive-heading location) - infile-p (equal file (abbreviate-file-name afile))) - (unless afile - (error "Invalid `org-archive-location'")) + (if (> (length afile) 0) + (setq newfile-p (not (file-exists-p afile)) + visiting (find-buffer-visiting afile) + buffer (or visiting (find-file-noselect afile))) + (setq buffer (current-buffer))) + (unless buffer + (error "Cannot access file \"%s\"" afile)) + (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 + (setq category (org-get-category nil 'force-refresh) + todo (and (looking-at org-todo-line-regexp) + (match-string 2)) + priority (org-get-priority + (if (match-end 3) (match-string 3) "")) + ltags (org-get-tags) + itags (org-delete-all ltags (org-get-tags-at)) + atags (org-get-tags-at)) + (setq ltags (mapconcat 'identity ltags " ") + itags (mapconcat 'identity itags " ")) + ;; 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 (eq major-mode '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 newfile-p + (goto-char (point-max)) + (insert (format "\nArchived entries from file %s\n\n" + (buffer-file-name this-buffer)))) + ;; 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) + (org-odd-levels-only + (if (local-variable-p 'org-odd-levels-only (current-buffer)) + org-odd-levels-only + tr-org-odd-levels-only))) + (goto-char (point-min)) + (show-all) + (if heading + (progn + (if (re-search-forward + (concat "^" (regexp-quote heading) + (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)")) + nil t) + (goto-char (match-end 0)) + ;; Heading not found, just insert it at the end + (goto-char (point-max)) + (or (bolp) (insert "\n")) + (insert "\n" heading "\n") + (end-of-line 0)) + ;; Make the subtree visible + (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]*") + (replace-match "\n\n"))) + ;; No specific heading, just go to end of file. + (goto-char (point-max)) (insert "\n")) + ;; Paste + (org-paste-subtree (org-get-valid-level level (and heading 1))) + ;; Shall we append inherited tags? + (and itags + (or (and (eq org-archive-subtree-add-inherited-tags 'infile) + infile-p) + (eq org-archive-subtree-add-inherited-tags t)) + (org-set-tags-to atags)) + ;; Mark the entry as done + (when (and org-archive-mark-done + (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))))) - (if (> (length afile) 0) - (setq newfile-p (not (file-exists-p afile)) - visiting (find-buffer-visiting afile) - buffer (or visiting (find-file-noselect afile))) - (setq buffer (current-buffer))) - (unless buffer - (error "Cannot access file \"%s\"" afile)) - (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 - (setq category (org-get-category nil 'force-refresh) - todo (and (looking-at org-todo-line-regexp) - (match-string 2)) - priority (org-get-priority - (if (match-end 3) (match-string 3) "")) - ltags (org-get-tags) - itags (org-delete-all ltags (org-get-tags-at)) - atags (org-get-tags-at)) - (setq ltags (mapconcat 'identity ltags " ") - itags (mapconcat 'identity itags " ")) - ;; 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 (eq major-mode '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 newfile-p - (goto-char (point-max)) - (insert (format "\nArchived entries from file %s\n\n" - (buffer-file-name this-buffer)))) - ;; 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) - (org-odd-levels-only - (if (local-variable-p 'org-odd-levels-only (current-buffer)) - org-odd-levels-only - tr-org-odd-levels-only))) - (goto-char (point-min)) - (show-all) - (if heading - (progn - (if (re-search-forward - (concat "^" (regexp-quote heading) - (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)")) - nil t) - (goto-char (match-end 0)) - ;; Heading not found, just insert it at the end - (goto-char (point-max)) - (or (bolp) (insert "\n")) - (insert "\n" heading "\n") - (end-of-line 0)) - ;; Make the subtree visible - (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]*") - (replace-match "\n\n"))) - ;; No specific heading, just go to end of file. - (goto-char (point-max)) (insert "\n")) - ;; Paste - (org-paste-subtree (org-get-valid-level level (and heading 1))) - ;; Shall we append inherited tags? - (and itags - (or (and (eq org-archive-subtree-add-inherited-tags 'infile) - infile-p) - (eq org-archive-subtree-add-inherited-tags t)) - (org-set-tags-to atags)) - ;; Mark the entry as done - (when (and org-archive-mark-done - (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 + (when org-archive-save-context-info + (let ((l org-archive-save-context-info) e n v) + (while (setq e (pop l)) + (when (and (setq v (symbol-value e)) + (stringp v) (string-match "\\S-" v)) + (setq n (concat "ARCHIVE_" (upcase (symbol-name e)))) + (org-entry-put (point) n v))))) - ;; Add the context info - (when org-archive-save-context-info - (let ((l org-archive-save-context-info) e n v) - (while (setq e (pop l)) - (when (and (setq v (symbol-value e)) - (stringp v) (string-match "\\S-" v)) - (setq n (concat "ARCHIVE_" (upcase (symbol-name e)))) - (org-entry-put (point) n v))))) - - ;; Save and kill the buffer, if it is not the same buffer. - (when (not (eq this-buffer buffer)) - (save-buffer)))) - ;; Here we are back in the original buffer. Everything seems to have - ;; worked. So now cut the tree and finish up. - (let (this-command) (org-cut-subtree)) - (when (featurep 'org-inlinetask) - (org-inlinetask-remove-END-maybe)) - (setq org-markers-to-move 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))) + ;; Save and kill the buffer, if it is not the same buffer. + (when (not (eq this-buffer buffer)) + (save-buffer)))) + ;; Here we are back in the original buffer. Everything seems to have + ;; worked. So now cut the tree and finish up. + (let (this-command) (org-cut-subtree)) + (when (featurep 'org-inlinetask) + (org-inlinetask-remove-END-maybe)) + (setq org-markers-to-move 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)))) (defun org-archive-to-archive-sibling () "Archive the current heading by moving it under the archive sibling. @@ -349,55 +356,68 @@ The archive sibling is a sibling of the heading with the heading name `org-archive-sibling-heading' and an `org-archive-tag' tag. If this sibling does not exist, it will be created at the end of the subtree." (interactive) - (save-restriction - (widen) - (let (b e pos leader level) - (org-back-to-heading t) - (looking-at org-outline-regexp) - (setq leader (match-string 0) - level (funcall outline-level)) - (setq pos (point)) - (condition-case nil - (outline-up-heading 1 t) - (error (setq e (point-max)) (goto-char (point-min)))) - (setq b (point)) - (unless e + (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) + (let (org-loop-over-headlines-in-active-region) + (org-map-entries + '(progn (setq org-map-continue-from + (progn (org-back-to-heading) + (if (looking-at (concat "^.*:" org-archive-tag ":.*$")) + (org-end-of-subtree t) + (point)))) + (when (org-at-heading-p) + (org-archive-to-archive-sibling))) + org-loop-over-headlines-in-active-region + 'region + (if (outline-invisible-p) (org-end-of-subtree nil t)))) + (save-restriction + (widen) + (let (b e pos leader level) + (org-back-to-heading t) + (looking-at org-outline-regexp) + (setq leader (match-string 0) + level (funcall outline-level)) + (setq pos (point)) (condition-case nil - (org-end-of-subtree t t) - (error (goto-char (point-max)))) - (setq e (point))) - (goto-char b) - (unless (re-search-forward - (concat "^" (regexp-quote leader) - "[ \t]*" - org-archive-sibling-heading - "[ \t]*:" - org-archive-tag ":") e t) - (goto-char e) - (or (bolp) (newline)) - (insert leader org-archive-sibling-heading "\n") - (beginning-of-line 0) - (org-toggle-tag org-archive-tag 'on)) - (beginning-of-line 1) - (if org-archive-reversed-order - (outline-next-heading) - (org-end-of-subtree t t)) - (save-excursion - (goto-char pos) - (let ((this-command this-command)) (org-cut-subtree))) - (org-paste-subtree (org-get-valid-level level 1)) - (org-set-property - "ARCHIVE_TIME" - (format-time-string - (substring (cdr org-time-stamp-formats) 1 -1) - (current-time))) - (outline-up-heading 1 t) - (hide-subtree) - (org-cycle-show-empty-lines 'folded) - (goto-char pos))) - (org-reveal) - (if (looking-at "^[ \t]*$") - (outline-next-visible-heading 1))) + (outline-up-heading 1 t) + (error (setq e (point-max)) (goto-char (point-min)))) + (setq b (point)) + (unless e + (condition-case nil + (org-end-of-subtree t t) + (error (goto-char (point-max)))) + (setq e (point))) + (goto-char b) + (unless (re-search-forward + (concat "^" (regexp-quote leader) + "[ \t]*" + org-archive-sibling-heading + "[ \t]*:" + org-archive-tag ":") e t) + (goto-char e) + (or (bolp) (newline)) + (insert leader org-archive-sibling-heading "\n") + (beginning-of-line 0) + (org-toggle-tag org-archive-tag 'on)) + (beginning-of-line 1) + (if org-archive-reversed-order + (outline-next-heading) + (org-end-of-subtree t t)) + (save-excursion + (goto-char pos) + (let ((this-command this-command)) (org-cut-subtree))) + (org-paste-subtree (org-get-valid-level level 1)) + (org-set-property + "ARCHIVE_TIME" + (format-time-string + (substring (cdr org-time-stamp-formats) 1 -1) + (current-time))) + (outline-up-heading 1 t) + (hide-subtree) + (org-cycle-show-empty-lines 'folded) + (goto-char pos))) + (org-reveal) + (if (looking-at "^[ \t]*$") + (outline-next-visible-heading 1)))) (defun org-archive-all-done (&optional tag) "Archive sublevels of the current tree without open TODO items. @@ -448,20 +468,34 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag." With prefix ARG, check all children of current headline and offer tagging the children that do not contain any open TODO items." (interactive "P") - (if find-done - (org-archive-all-done 'tag) - (let (set) - (save-excursion - (org-back-to-heading t) - (setq set (org-toggle-tag org-archive-tag)) - (when set (hide-subtree))) - (and set (beginning-of-line 1)) - (message "Subtree %s" (if set "archived" "unarchived"))))) + (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) + (let (org-loop-over-headlines-in-active-region) + (org-map-entries + `(org-toggle-archive-tag ,find-done) + org-loop-over-headlines-in-active-region + 'region + (if (outline-invisible-p) (org-end-of-subtree nil t)))) + (if find-done + (org-archive-all-done 'tag) + (let (set) + (save-excursion + (org-back-to-heading t) + (setq set (org-toggle-tag org-archive-tag)) + (when set (hide-subtree))) + (and set (beginning-of-line 1)) + (message "Subtree %s" (if set "archived" "unarchived")))))) (defun org-archive-set-tag () "Set the ARCHIVE tag." (interactive) - (org-toggle-tag org-archive-tag 'on)) + (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) + (let (org-loop-over-headlines-in-active-region) + (org-map-entries + 'org-archive-set-tag + org-loop-over-headlines-in-active-region + 'region + (if (outline-invisible-p) (org-end-of-subtree nil t)))) + (org-toggle-tag org-archive-tag 'on))) ;;;###autoload (defun org-archive-subtree-default () From dec7efc41490b9fb2c1bc849eb670643578af1ad Mon Sep 17 00:00:00 2001 From: Bastien Guerry Date: Fri, 30 Dec 2011 11:09:26 +0100 Subject: [PATCH 2/3] New allowed value 'start-level for `org-loop-over-headlines-in-active-region'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * org.el (org-scan-tags): New parameter `start-level' to scan only through headlines of that level. (org-map-entries): New allowed value `region-start-level' for the `scope' parameter, to allow scanning through headlines of the same level than the first headline in the region. (org-loop-over-headlines-in-active-region): New allowed value 'start-level. This change gives more flexibility when looping over the active region for commands like `org-schedule', `org-deadline', etc. By setting `org-loop-over-headlines-in-active-region' to ̀€start-level', those command will act upon headlines that are of the same level than the first one in the region. --- lisp/org.el | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/lisp/org.el b/lisp/org.el index 13a0f44a0..d5b75946b 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -410,6 +410,10 @@ XEmacs user should have this variable set to nil, because When set to `t', some commands will be performed in all headlines within the active region. +When set to `start-level', some commands will be performed in all +headlines within the active region, provided that these headlines +are of the same level than the first one. + When set to a string, those commands will be performed on the matching headlines within the active region. Such string must be a tags/property/todo match as it is used in the agenda tags view. @@ -419,6 +423,7 @@ The list of commands is: - `org-deadline'" :type '(choice (const :tag "Don't loop" nil) (const :tag "All headlines in active region" t) + (const :tag "In active region, headlines at the same level than the first one" 'start-level) (string :tag "Tags/Property/Todo matcher")) :group 'org-todo :group 'org-archive) @@ -12718,7 +12723,7 @@ obtain a list of properties. Building the tags list for each entry in such a file becomes an N^2 operation - but with this variable set, it scales as N.") -(defun org-scan-tags (action matcher &optional todo-only) +(defun org-scan-tags (action matcher &optional todo-only start-level) "Scan headline tags with inheritance and produce output ACTION. ACTION can be `sparse-tree' to produce a sparse tree in the current buffer, @@ -12728,9 +12733,17 @@ this case the return value is a list of all return values from these calls. MATCHER is a Lisp form to be evaluated, testing if a given set of tags qualifies a headline for inclusion. When TODO-ONLY is non-nil, -only lines with a TODO keyword are included in the output." +only lines with a TODO keyword are included in the output. + +START-LEVEL can be a string with asterisks, reducing the scope to +headlines matching this string." (require 'org-agenda) - (let* ((re (concat "^" org-outline-regexp " *\\(\\<\\(" + (let* ((re (concat "^" + (if start-level + ;; Get the correct level to match + (concat "\\*\\{" (number-to-string start-level) "\\} ") + org-outline-regexp) + " *\\(\\<\\(" (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") (org-re "\\>\\)\\)? *\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$"))) @@ -13724,6 +13737,9 @@ SCOPE determines the scope of this command. It can be any of: nil The current buffer, respecting the restriction if any tree The subtree started with the entry at point region The entries within the active region, if any +region-start-level + The entries within the active region, but only those at + the same level than the first one. file The current buffer, without restriction file-with-archives The current buffer, and any archives associated with it @@ -13752,13 +13768,15 @@ with `org-get-tags-at'. If your function gets properties with to t around the call to `org-entry-properties' to get the same speedup. Note that if your function moves around to retrieve tags and properties at a *different* entry, you cannot use these techniques." - (unless (and (eq scope 'region) (not (org-region-active-p))) + (unless (and (or (eq scope 'region) (eq scope 'region-start-level)) + (not (org-region-active-p))) (let* ((org-agenda-archives-mode nil) ; just to make sure (org-agenda-skip-archived-trees (memq 'archive skip)) (org-agenda-skip-comment-trees (memq 'comment skip)) (org-agenda-skip-function (car (org-delete-all '(comment archive) skip))) (org-tags-match-list-sublevels t) + (start-level (eq scope 'region-start-level)) matcher file res org-todo-keywords-for-agenda org-done-keywords-for-agenda @@ -13777,7 +13795,14 @@ a *different* entry, you cannot use these techniques." (org-back-to-heading t) (org-narrow-to-subtree) (setq scope nil)) - ((and (eq scope 'region) (org-region-active-p)) + ((and (or (eq scope 'region) (eq scope 'region-start-level)) + (org-region-active-p)) + ;; If needed, set start-level to a string like "2" + (when start-level + (save-excursion + (goto-char (region-beginning)) + (unless (org-at-heading-p) (outline-next-heading)) + (setq start-level (org-current-level)))) (narrow-to-region (region-beginning) (save-excursion (goto-char (region-end)) @@ -13790,7 +13815,7 @@ a *different* entry, you cannot use these techniques." (progn (org-prepare-agenda-buffers (list (buffer-file-name (current-buffer)))) - (setq res (org-scan-tags func matcher))) + (setq res (org-scan-tags func matcher nil start-level))) ;; Get the right scope (cond ((and scope (listp scope) (symbolp (car scope))) From 834d9514bd05c1b9bc3f46b9db52c6f4fd395045 Mon Sep 17 00:00:00 2001 From: Bastien Guerry Date: Fri, 30 Dec 2011 11:13:45 +0100 Subject: [PATCH 3/3] Handle 'start-level value of `org-loop-over-headlines-in-active-region' for archiving commands. * org-archive.el (org-archive-subtree) (org-archive-to-archive-sibling, org-toggle-archive-tag) (org-archive-set-tag): Handle the 'start-level value for `org-loop-over-headlines-in-active-region'. --- lisp/org-archive.el | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/lisp/org-archive.el b/lisp/org-archive.el index 9c0827a53..27a78e40e 100644 --- a/lisp/org-archive.el +++ b/lisp/org-archive.el @@ -191,13 +191,14 @@ If the cursor is not at a headline when this command is called, try all level this heading." (interactive "P") (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) - (let (org-loop-over-headlines-in-active-region) + (let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level) + 'region-current-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 - 'region - (if (outline-invisible-p) (org-end-of-subtree nil t)))) + cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) (if find-done (org-archive-all-done) ;; Save all relevant TODO keyword-relatex variables @@ -357,7 +358,9 @@ The archive sibling is a sibling of the heading with the heading name sibling does not exist, it will be created at the end of the subtree." (interactive) (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) - (let (org-loop-over-headlines-in-active-region) + (let ((cl (when (eq org-loop-over-headlines-in-active-region 'start-level) + 'region-current-level 'region)) + org-loop-over-headlines-in-active-region) (org-map-entries '(progn (setq org-map-continue-from (progn (org-back-to-heading) @@ -367,8 +370,7 @@ sibling does not exist, it will be created at the end of the subtree." (when (org-at-heading-p) (org-archive-to-archive-sibling))) org-loop-over-headlines-in-active-region - 'region - (if (outline-invisible-p) (org-end-of-subtree nil t)))) + cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) (save-restriction (widen) (let (b e pos leader level) @@ -469,12 +471,13 @@ With prefix ARG, check all children of current headline and offer tagging the children that do not contain any open TODO items." (interactive "P") (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) - (let (org-loop-over-headlines-in-active-region) + (let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level) + 'region-current-level 'region)) + org-loop-over-headlines-in-active-region) (org-map-entries `(org-toggle-archive-tag ,find-done) org-loop-over-headlines-in-active-region - 'region - (if (outline-invisible-p) (org-end-of-subtree nil t)))) + cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) (if find-done (org-archive-all-done 'tag) (let (set) @@ -489,12 +492,13 @@ the children that do not contain any open TODO items." "Set the ARCHIVE tag." (interactive) (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) - (let (org-loop-over-headlines-in-active-region) + (let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level) + 'region-current-level 'region)) + org-loop-over-headlines-in-active-region) (org-map-entries 'org-archive-set-tag org-loop-over-headlines-in-active-region - 'region - (if (outline-invisible-p) (org-end-of-subtree nil t)))) + cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) (org-toggle-tag org-archive-tag 'on))) ;;;###autoload