;;; org-archive.el --- Archiving for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2012 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.02b
;;
;; This file is part of GNU Emacs.
;;
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
-;; This file contains the face definitons for Org.
+;; This file contains the face definitions for Org.
;;; Code:
(require 'org)
+(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
+
+(defcustom org-archive-default-command 'org-archive-subtree
+ "The default archiving command."
+ :group 'org-archive
+ :type '(choice
+ (const org-archive-subtree)
+ (const org-archive-to-archive-sibling)
+ (const org-archive-set-tag)))
+
+(defcustom org-archive-reversed-order nil
+ "Non-nil means make the tree first child under the archive heading, not last."
+ :group 'org-archive
+ :type 'boolean)
+
(defcustom org-archive-sibling-heading "Archive"
"Name of the local archive sibling that is used to archive entries locally.
Locally means: in the tree, under a sibling.
:group 'org-archive
:type 'string)
-(defcustom org-archive-mark-done t
- "Non-nil means, mark entries as DONE when they are moved to the archive file.
+(defcustom org-archive-mark-done nil
+ "Non-nil means mark entries as DONE when they are moved to the archive file.
This can be a string to set the keyword to use. When t, Org-mode will
use the first keyword in its list that means done."
:group 'org-archive
(string :tag "Use this keyword")))
(defcustom org-archive-stamp-time t
- "Non-nil means, add a time stamp to entries moved to an archive file.
-This variable is obsolete and has no effect anymore, instead add ot remove
-`time' from the variablle `org-archive-save-context-info'."
+ "Non-nil means add a time stamp to entries moved to an archive file.
+This variable is obsolete and has no effect anymore, instead add or remove
+`time' from the variable `org-archive-save-context-info'."
:group 'org-archive
:type 'boolean)
+(defcustom org-archive-subtree-add-inherited-tags 'infile
+ "Non-nil means append inherited tags when archiving a subtree."
+ :group 'org-archive
+ :type '(choice
+ (const :tag "Never" nil)
+ (const :tag "When archiving a subtree to the same file" infile)
+ (const :tag "Always" t)))
+
(defcustom org-archive-save-context-info '(time file olpath category todo itags)
"Parts of context info that should be stored as properties when archiving.
-When a subtree is moved to an archive file, it looses information given by
+When a subtree is moved to an archive file, it loses information given by
context, like inherited tags, the category, and possibly also the TODO
state (depending on the variable `org-archive-mark-done').
This variable can be a list of any of the following symbols:
time The time of archiving.
file The file where the entry originates.
-itags The local tags, in the headline of the subtree.
-ltags The tags the subtree inherits from further up the hierarchy.
+ltags The local tags, in the headline of the subtree.
+itags The tags the subtree inherits from further up the hierarchy.
todo The pre-archive TODO state.
category The category, taken from file name or #+CATEGORY lines.
olpath The outline path to the item. These are all headlines above
the current item, separated by /, like a file path.
For each symbol present in the list, a property will be created in
-the archived entry, with a prefix \"PRE_ARCHIVE_\", to remember this
+the archived entry, with a prefix \"ARCHIVE_\", to remember this
information."
:group 'org-archive
:type '(set :greedy t
(const :tag "File" file)
(const :tag "Category" category)
(const :tag "TODO state" todo)
- (const :tag "TODO state" priority)
+ (const :tag "Priority" priority)
(const :tag "Inherited tags" itags)
(const :tag "Outline path" olpath)
(const :tag "Local tags" ltags)))
((or (re-search-backward re nil t)
(re-search-forward re nil t))
(match-string 1))
- (t org-archive-location (match-string 1)))))))
+ (t org-archive-location))))))
(defun org-add-archive-files (files)
- "Splice the archive files into the list f files.
+ "Splice the archive files into the list of files.
This implies visiting all these files and finding out what the
archive file is."
- (apply
- 'append
- (mapcar
- (lambda (f)
- (if (not (file-exists-p f))
- nil
- (with-current-buffer (org-get-agenda-file-buffer f)
- (cons f (org-all-archive-files)))))
- files)))
+ (org-uniquify
+ (apply
+ 'append
+ (mapcar
+ (lambda (f)
+ (if (not (file-exists-p f))
+ nil
+ (with-current-buffer (org-get-agenda-file-buffer f)
+ (cons f (org-all-archive-files)))))
+ files))))
(defun org-all-archive-files ()
"Get a list of all archive files used in the current buffer."
files))
(defun org-extract-archive-file (&optional location)
+ "Extract and expand the file name from archive LOCATION.
+if LOCATION is not given, the value of `org-archive-location' is used."
(setq location (or location org-archive-location))
(if (string-match "\\(.*\\)::\\(.*\\)" location)
(if (= (match-beginning 1) (match-end 1))
- (buffer-file-name)
+ (buffer-file-name (buffer-base-buffer))
(expand-file-name
- (format (match-string 1 location) buffer-file-name)))))
+ (format (match-string 1 location)
+ (file-name-nondirectory
+ (buffer-file-name (buffer-base-buffer))))))))
(defun org-extract-archive-heading (&optional location)
+ "Extract the heading from archive LOCATION.
+if LOCATION is not given, the value of `org-archive-location' is used."
(setq location (or location org-archive-location))
(if (string-match "\\(.*\\)::\\(.*\\)" location)
- (match-string 2 location)))
+ (format (match-string 2 location)
+ (file-name-nondirectory
+ (buffer-file-name (buffer-base-buffer))))))
(defun org-archive-subtree (&optional find-done)
"Move the current subtree to the archive.
When called with prefix argument FIND-DONE, find whole trees without any
open TODO items and archive them (after getting confirmation from the user).
-If the cursor is not at a headline when this comand is called, try all level
+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
-
- (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 (buffer-file-name)))
- (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
- ;; end of variables that will be used for saving context
- location afile heading buffer level newfile-p)
-
- ;; Find the local archive location
- (setq location (org-get-local-archive-location)
- afile (org-extract-archive-file location)
- heading (org-extract-archive-heading location))
- (unless afile
- (error "Invalid `org-archive-location'"))
-
- (if (> (length afile) 0)
- (setq newfile-p (not (file-exists-p afile))
- buffer (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
- (org-refresh-category-properties)
- (setq category (org-get-category)
- 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)))
- (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))
- (set-buffer buffer)
- ;; Enforce org-mode for the archive buffer
- (if (not (org-mode-p))
- ;; 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)
- (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 1))
-
- ;; 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)))))
-
- ;; Save and kill the buffer, if it is not the same buffer.
- (if (not (eq this-buffer buffer))
- (progn (save-buffer) (kill-buffer 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))
- (if (and (not (eobp)) (looking-at "[ \t]*$")) (kill-line))
- (message "Subtree archived %s"
- (if (eq this-buffer buffer)
- (concat "under heading: " heading)
- (concat "in file: " (abbreviate-file-name afile)))))))
+ (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 (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)
+
+ ;; 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)))))
+
+ ;; 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))))
(defun org-archive-to-archive-sibling ()
"Archive the current heading by moving it under the archive sibling.
`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 outline-regexp)
- (setq leader (match-string 0)
- level (funcall outline-level))
- (setq pos (point))
- (condition-case nil
- (outline-up-heading 1 t)
- (error (goto-char (point-min))))
- (setq b (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)
- (org-end-of-subtree t t)
- (save-excursion
- (goto-char pos)
- (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)
- (goto-char pos))))
+ (if (and (org-region-active-p) org-loop-over-headlines-in-active-region)
+ (let ((cl (when (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)
+ (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
+ cl (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
+ (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.
If the cursor is not on a headline, try all level 1 trees. If
it is on a headline, try all direct children.
When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
- (let ((re (concat "^\\*+ +" org-not-done-regexp)) re1
+ (let ((re org-not-done-heading-regexp) re1
(rea (concat ".*:" org-archive-tag ":"))
(begm (make-marker))
(endm (make-marker))
(question (if tag "Set ARCHIVE tag (no open TODO items)? "
"Move subtree to archive (no open TODO items)? "))
beg end (cntarch 0))
- (if (org-on-heading-p)
+ (if (org-at-heading-p)
(progn
(setq re1 (concat "^" (regexp-quote
(make-string
- (1+ (- (match-end 0) (match-beginning 0) 1))
+ (+ (- (match-end 0) (match-beginning 0) 1)
+ (if org-odd-levels-only 2 1))
?*))
" "))
(move-marker begm (point))
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 ((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
+ `(org-toggle-archive-tag ,find-done)
+ org-loop-over-headlines-in-active-region
+ cl (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)
+ (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
+ 'org-archive-set-tag
+ org-loop-over-headlines-in-active-region
+ cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
+ (org-toggle-tag org-archive-tag 'on)))
+
+;;;###autoload
+(defun org-archive-subtree-default ()
+ "Archive the current subtree with the default command.
+This command is set with the variable `org-archive-default-command'."
+ (interactive)
+ (call-interactively org-archive-default-command))
+
+;;;###autoload
+(defun org-archive-subtree-default-with-confirmation ()
+ "Archive the current subtree with the default command.
+This command is set with the variable `org-archive-default-command'."
+ (interactive)
+ (if (y-or-n-p "Archive this subtree or entry? ")
+ (call-interactively org-archive-default-command)
+ (error "Abort")))
(provide 'org-archive)
-;; arch-tag: 0837f601-9699-43c3-8b90-631572ae6c85
;;; org-archive.el ends here