[bpt/emacs.git] / lisp / org / org-archive.el

;;; org-archive.el --- Archiving for Org-mode

;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009
;;   Free Software Foundation, Inc.

;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;; Version: 6.20c
;;
;; This file is part of GNU Emacs.
;;
;; 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 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:

;; This file contains the face definitions for Org.

;;; Code:

(require 'org)

(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.
See `org-archive-to-archive-sibling' for more information."
  :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.
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
  :type '(choice
	  (const :tag "No" nil)
	  (const :tag "Yes" t)
	  (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 or remove
`time' from the variable `org-archive-save-context-info'."
  :group 'org-archive
  :type 'boolean)

(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 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.
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
information."
  :group 'org-archive
  :type '(set :greedy t
	  (const :tag "Time" time)
	  (const :tag "File" file)
	  (const :tag "Category" category)
	  (const :tag "TODO state" todo)
	  (const :tag "Priority" priority)
	  (const :tag "Inherited tags" itags)
	  (const :tag "Outline path" olpath)
	  (const :tag "Local tags" ltags)))

(defun org-get-local-archive-location ()
  "Get the archive location applicable at point."
  (let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
	prop)
    (save-excursion
      (save-restriction
	(widen)
	(setq prop (org-entry-get nil "ARCHIVE" 'inherit))
	(cond
	 ((and prop (string-match "\\S-" prop))
	  prop)
	 ((or (re-search-backward re nil t)
	      (re-search-forward re nil t))
	  (match-string 1))
	 (t org-archive-location (match-string 1)))))))

(defun org-add-archive-files (files)
  "Splice the archive files into the list of files.
This implies visiting all these files and finding out what the
archive file is."
  (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."
  (let (file files)
    (save-excursion
      (save-restriction
	(goto-char (point-min))
	(while (re-search-forward
		"^\\(#\\+\\|[ \t]*:\\)ARCHIVE:[ \t]+\\(.*\\)"
		nil t)
	  (setq file (org-extract-archive-file
		      (org-match-string-no-properties 2)))
	  (and file (> (length file) 0) (file-exists-p file)
	       (add-to-list 'files file)))))
    (setq files (nreverse files))
    (setq file (org-extract-archive-file))
    (and file (> (length file) 0) (file-exists-p file)
	 (add-to-list 'files file))
    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)
	(expand-file-name
	 (format (match-string 1 location)
		 (file-name-nondirectory buffer-file-name))))))

(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)
      (format (match-string 2 location)
	      (file-name-nondirectory buffer-file-name))))

(defun org-archive-subtree (&optional find-done)
  "Move the current subtree to the archive.
The archive can be a certain top-level heading in the current file, or in
a different file.  The tree will be moved to that location, the subtree
heading be marked DONE, and the current time will be added.

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 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 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))
      (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
	(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 1 nil t))
	(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.
	  (when (not (eq this-buffer buffer))
	    (save-buffer)
	    ;; Check if it is OK to kill the buffer
	    (unless
		(or visiting
		    (equal (marker-buffer org-clock-marker) (current-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))
      (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))

(defun org-archive-to-archive-sibling ()
  "Archive the current heading by moving it under the archive sibling.
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 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)
      (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))

(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
	(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)
	(progn
	  (setq re1 (concat "^" (regexp-quote
				 (make-string
				  (1+ (- (match-end 0) (match-beginning 0) 1))
				  ?*))
			    " "))
	  (move-marker begm (point))
	  (move-marker endm (org-end-of-subtree t)))
      (setq re1 "^* ")
      (move-marker begm (point-min))
      (move-marker endm (point-max)))
    (save-excursion
      (goto-char begm)
      (while (re-search-forward re1 endm t)
	(setq beg (match-beginning 0)
	      end (save-excursion (org-end-of-subtree t) (point)))
	(goto-char beg)
	(if (re-search-forward re end t)
	    (goto-char end)
	  (goto-char beg)
	  (if (and (or (not tag) (not (looking-at rea)))
		   (y-or-n-p question))
	      (progn
		(if tag
		    (org-toggle-tag org-archive-tag 'on)
		  (org-archive-subtree))
		(setq cntarch (1+ cntarch)))
	    (goto-char end)))))
    (message "%d trees archived" cntarch)))

(defun org-toggle-archive-tag (&optional find-done)
  "Toggle the archive tag for the current headline.
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")))))

(provide 'org-archive)

;; arch-tag: 0837f601-9699-43c3-8b90-631572ae6c85

;;; org-archive.el ends here
Commit	Line	Data
20908596 CD	1	;;; org-archive.el --- Archiving for Org-mode
20908596 CD	2
1e4f816a CD	3	;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009
1e4f816a CD	4	;; Free Software Foundation, Inc.
20908596 CD	5
	6	;; Author: Carsten Dominik <carsten at orgmode dot org>
	7	;; Keywords: outlines, hypermedia, calendar, wp
	8	;; Homepage: http://orgmode.org
d6685abc	9	;; Version: 6.20c
20908596 CD	10	;;
	11	;; This file is part of GNU Emacs.
	12	;;
b1fc2b50	13	;; GNU Emacs is free software: you can redistribute it and/or modify
20908596	14	;; it under the terms of the GNU General Public License as published by
b1fc2b50 GM	15	;; the Free Software Foundation, either version 3 of the License, or
b1fc2b50 GM	16	;; (at your option) any later version.
20908596 CD	17
	18	;; GNU Emacs is distributed in the hope that it will be useful,
	19	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	20	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	21	;; GNU General Public License for more details.
	22
	23	;; You should have received a copy of the GNU General Public License
b1fc2b50	24	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
20908596 CD	25	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	26	;;
	27	;;; Commentary:
	28
33306645	29	;; This file contains the face definitions for Org.
20908596 CD	30
	31	;;; Code:
	32
	33	(require 'org)
	34
	35	(defcustom org-archive-sibling-heading "Archive"
	36	"Name of the local archive sibling that is used to archive entries locally.
	37	Locally means: in the tree, under a sibling.
	38	See `org-archive-to-archive-sibling' for more information."
	39	:group 'org-archive
	40	:type 'string)
	41
	42	(defcustom org-archive-mark-done t
	43	"Non-nil means, mark entries as DONE when they are moved to the archive file.
	44	This can be a string to set the keyword to use. When t, Org-mode will
	45	use the first keyword in its list that means done."
	46	:group 'org-archive
	47	:type '(choice
	48	(const :tag "No" nil)
	49	(const :tag "Yes" t)
	50	(string :tag "Use this keyword")))
	51
	52	(defcustom org-archive-stamp-time t
	53	"Non-nil means, add a time stamp to entries moved to an archive file.
423a66f9 JB	54	This variable is obsolete and has no effect anymore, instead add or remove
423a66f9 JB	55	`time' from the variable `org-archive-save-context-info'."
20908596 CD	56	:group 'org-archive
	57	:type 'boolean)
	58
	59	(defcustom org-archive-save-context-info '(time file olpath category todo itags)
	60	"Parts of context info that should be stored as properties when archiving.
423a66f9	61	When a subtree is moved to an archive file, it loses information given by
20908596 CD	62	context, like inherited tags, the category, and possibly also the TODO
	63	state (depending on the variable `org-archive-mark-done').
	64	This variable can be a list of any of the following symbols:
	65
	66	time The time of archiving.
	67	file The file where the entry originates.
b349f79f CD	68	ltags The local tags, in the headline of the subtree.
b349f79f CD	69	itags The tags the subtree inherits from further up the hierarchy.
20908596 CD	70	todo The pre-archive TODO state.
	71	category The category, taken from file name or #+CATEGORY lines.
	72	olpath The outline path to the item. These are all headlines above
	73	the current item, separated by /, like a file path.
	74
	75	For each symbol present in the list, a property will be created in
	76	the archived entry, with a prefix \"PRE_ARCHIVE_\", to remember this
	77	information."
	78	:group 'org-archive
	79	:type '(set :greedy t
	80	(const :tag "Time" time)
	81	(const :tag "File" file)
	82	(const :tag "Category" category)
	83	(const :tag "TODO state" todo)
b349f79f	84	(const :tag "Priority" priority)
20908596 CD	85	(const :tag "Inherited tags" itags)
	86	(const :tag "Outline path" olpath)
	87	(const :tag "Local tags" ltags)))
	88
	89	(defun org-get-local-archive-location ()
	90	"Get the archive location applicable at point."
	91	(let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.\\S-\\)[ \t]$")
	92	prop)
	93	(save-excursion
	94	(save-restriction
	95	(widen)
	96	(setq prop (org-entry-get nil "ARCHIVE" 'inherit))
	97	(cond
	98	((and prop (string-match "\\S-" prop))
	99	prop)
	100	((or (re-search-backward re nil t)
	101	(re-search-forward re nil t))
	102	(match-string 1))
	103	(t org-archive-location (match-string 1)))))))
	104
	105	(defun org-add-archive-files (files)
0bd48b37	106	"Splice the archive files into the list of files.
20908596 CD	107	This implies visiting all these files and finding out what the
20908596 CD	108	archive file is."
0bd48b37 CD	109	(org-uniquify
	110	(apply
	111	'append
	112	(mapcar
	113	(lambda (f)
	114	(if (not (file-exists-p f))
	115	nil
	116	(with-current-buffer (org-get-agenda-file-buffer f)
	117	(cons f (org-all-archive-files)))))
	118	files))))
20908596 CD	119
	120	(defun org-all-archive-files ()
	121	"Get a list of all archive files used in the current buffer."
	122	(let (file files)
	123	(save-excursion
	124	(save-restriction
	125	(goto-char (point-min))
	126	(while (re-search-forward
	127	"^\\(#\\+\\\|[ \t]:\\)ARCHIVE:[ \t]+\\(.\\)"
	128	nil t)
	129	(setq file (org-extract-archive-file
	130	(org-match-string-no-properties 2)))
	131	(and file (> (length file) 0) (file-exists-p file)
	132	(add-to-list 'files file)))))
	133	(setq files (nreverse files))
	134	(setq file (org-extract-archive-file))
	135	(and file (> (length file) 0) (file-exists-p file)
	136	(add-to-list 'files file))
	137	files))
	138
	139	(defun org-extract-archive-file (&optional location)
b349f79f CD	140	"Extract and expand the file name from archive LOCATION.
b349f79f CD	141	if LOCATION is not given, the value of `org-archive-location' is used."
20908596 CD	142	(setq location (or location org-archive-location))
	143	(if (string-match "\\(.\\)::\\(.\\)" location)
	144	(if (= (match-beginning 1) (match-end 1))
	145	(buffer-file-name)
	146	(expand-file-name
b349f79f CD	147	(format (match-string 1 location)
b349f79f CD	148	(file-name-nondirectory buffer-file-name))))))
20908596 CD	149
20908596 CD	150	(defun org-extract-archive-heading (&optional location)
b349f79f CD	151	"Extract the heading from archive LOCATION.
b349f79f CD	152	if LOCATION is not given, the value of `org-archive-location' is used."
20908596 CD	153	(setq location (or location org-archive-location))
20908596 CD	154	(if (string-match "\\(.\\)::\\(.\\)" location)
0bd48b37 CD	155	(format (match-string 2 location)
0bd48b37 CD	156	(file-name-nondirectory buffer-file-name))))
20908596 CD	157
	158	(defun org-archive-subtree (&optional find-done)
	159	"Move the current subtree to the archive.
	160	The archive can be a certain top-level heading in the current file, or in
	161	a different file. The tree will be moved to that location, the subtree
	162	heading be marked DONE, and the current time will be added.
	163
	164	When called with prefix argument FIND-DONE, find whole trees without any
	165	open TODO items and archive them (after getting confirmation from the user).
33306645	166	If the cursor is not at a headline when this command is called, try all level
20908596 CD	167	1 trees. If the cursor is on a headline, only try the direct children of
	168	this heading."
	169	(interactive "P")
	170	(if find-done
	171	(org-archive-all-done)
	172	;; Save all relevant TODO keyword-relatex variables
	173
	174	(let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
	175	(tr-org-todo-keywords-1 org-todo-keywords-1)
	176	(tr-org-todo-kwd-alist org-todo-kwd-alist)
	177	(tr-org-done-keywords org-done-keywords)
	178	(tr-org-todo-regexp org-todo-regexp)
	179	(tr-org-todo-line-regexp org-todo-line-regexp)
	180	(tr-org-odd-levels-only org-odd-levels-only)
	181	(this-buffer (current-buffer))
	182	;; start of variables that will be used for saving context
	183	;; The compiler complains about them - keep them anyway!
	184	(file (abbreviate-file-name (buffer-file-name)))
	185	(olpath (mapconcat 'identity (org-get-outline-path) "/"))
	186	(time (format-time-string
	187	(substring (cdr org-time-stamp-formats) 1 -1)
	188	(current-time)))
	189	category todo priority ltags itags
	190	;; end of variables that will be used for saving context
b349f79f	191	location afile heading buffer level newfile-p visiting)
20908596 CD	192
	193	;; Find the local archive location
	194	(setq location (org-get-local-archive-location)
	195	afile (org-extract-archive-file location)
	196	heading (org-extract-archive-heading location))
	197	(unless afile
	198	(error "Invalid `org-archive-location'"))
	199
	200	(if (> (length afile) 0)
	201	(setq newfile-p (not (file-exists-p afile))
b349f79f CD	202	visiting (find-buffer-visiting afile)
b349f79f CD	203	buffer (or visiting (find-file-noselect afile)))
20908596 CD	204	(setq buffer (current-buffer)))
	205	(unless buffer
	206	(error "Cannot access file \"%s\"" afile))
	207	(if (and (> (length heading) 0)
	208	(string-match "^\\*+" heading))
	209	(setq level (match-end 0))
	210	(setq heading nil level 0))
	211	(save-excursion
	212	(org-back-to-heading t)
	213	;; Get context information that will be lost by moving the tree
	214	(org-refresh-category-properties)
	215	(setq category (org-get-category)
	216	todo (and (looking-at org-todo-line-regexp)
	217	(match-string 2))
	218	priority (org-get-priority
	219	(if (match-end 3) (match-string 3) ""))
	220	ltags (org-get-tags)
	221	itags (org-delete-all ltags (org-get-tags-at)))
	222	(setq ltags (mapconcat 'identity ltags " ")
	223	itags (mapconcat 'identity itags " "))
	224	;; We first only copy, in case something goes wrong
b349f79f	225	;; we need to protect `this-command', to avoid kill-region sets it,
20908596	226	;; which would lead to duplication of subtrees
b349f79f	227	(let (this-command) (org-copy-subtree 1 nil t))
20908596 CD	228	(set-buffer buffer)
	229	;; Enforce org-mode for the archive buffer
	230	(if (not (org-mode-p))
	231	;; Force the mode for future visits.
	232	(let ((org-insert-mode-line-in-empty-file t)
	233	(org-inhibit-startup t))
	234	(call-interactively 'org-mode)))
	235	(when newfile-p
	236	(goto-char (point-max))
	237	(insert (format "\nArchived entries from file %s\n\n"
	238	(buffer-file-name this-buffer))))
	239	;; Force the TODO keywords of the original buffer
	240	(let ((org-todo-line-regexp tr-org-todo-line-regexp)
	241	(org-todo-keywords-1 tr-org-todo-keywords-1)
	242	(org-todo-kwd-alist tr-org-todo-kwd-alist)
	243	(org-done-keywords tr-org-done-keywords)
	244	(org-todo-regexp tr-org-todo-regexp)
	245	(org-todo-line-regexp tr-org-todo-line-regexp)
	246	(org-odd-levels-only
	247	(if (local-variable-p 'org-odd-levels-only (current-buffer))
	248	org-odd-levels-only
	249	tr-org-odd-levels-only)))
	250	(goto-char (point-min))
	251	(show-all)
	252	(if heading
	253	(progn
	254	(if (re-search-forward
	255	(concat "^" (regexp-quote heading)
	256	(org-re "[ \t]\\(:[[:alnum:]_@:]+:\\)?[ \t]\\($\\\|\r\\)"))
	257	nil t)
	258	(goto-char (match-end 0))
	259	;; Heading not found, just insert it at the end
	260	(goto-char (point-max))
	261	(or (bolp) (insert "\n"))
	262	(insert "\n" heading "\n")
	263	(end-of-line 0))
	264	;; Make the subtree visible
	265	(show-subtree)
	266	(org-end-of-subtree t)
	267	(skip-chars-backward " \t\r\n")
	268	(and (looking-at "[ \t\r\n]*")
	269	(replace-match "\n\n")))
	270	;; No specific heading, just go to end of file.
	271	(goto-char (point-max)) (insert "\n"))
	272	;; Paste
	273	(org-paste-subtree (org-get-valid-level level 1))
	274
	275	;; Mark the entry as done
	276	(when (and org-archive-mark-done
	277	(looking-at org-todo-line-regexp)
	278	(or (not (match-end 2))
	279	(not (member (match-string 2) org-done-keywords))))
	280	(let (org-log-done org-todo-log-states)
	281	(org-todo
	282	(car (or (member org-archive-mark-done org-done-keywords)
	283	org-done-keywords)))))
	284
	285	;; Add the context info
	286	(when org-archive-save-context-info
	287	(let ((l org-archive-save-context-info) e n v)
	288	(while (setq e (pop l))
	289	(when (and (setq v (symbol-value e))
	290	(stringp v) (string-match "\\S-" v))
	291	(setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
292	(org-entry-put (point) n v)))))
293
294	;; Save and kill the buffer, if it is not the same buffer.
b349f79f CD	295	(when (not (eq this-buffer buffer))
	296	(save-buffer)
	297	;; Check if it is OK to kill the buffer
	298	(unless
	299	(or visiting
	300	(equal (marker-buffer org-clock-marker) (current-buffer)))
	301	(kill-buffer buffer)))
	302	))
20908596 CD	303	;; Here we are back in the original buffer. Everything seems to have
	304	;; worked. So now cut the tree and finish up.
	305	(let (this-command) (org-cut-subtree))
b349f79f	306	(setq org-markers-to-move nil)
20908596 CD	307	(message "Subtree archived %s"
	308	(if (eq this-buffer buffer)
	309	(concat "under heading: " heading)
0bd48b37 CD	310	(concat "in file: " (abbreviate-file-name afile))))))
0bd48b37 CD	311	(org-reveal))
20908596 CD	312
	313	(defun org-archive-to-archive-sibling ()
	314	"Archive the current heading by moving it under the archive sibling.
	315	The archive sibling is a sibling of the heading with the heading name
	316	`org-archive-sibling-heading' and an `org-archive-tag' tag. If this
	317	sibling does not exist, it will be created at the end of the subtree."
	318	(interactive)
	319	(save-restriction
	320	(widen)
	321	(let (b e pos leader level)
	322	(org-back-to-heading t)
	323	(looking-at outline-regexp)
	324	(setq leader (match-string 0)
	325	level (funcall outline-level))
	326	(setq pos (point))
	327	(condition-case nil
	328	(outline-up-heading 1 t)
71d35b24	329	(error (setq e (point-max)) (goto-char (point-min))))
20908596	330	(setq b (point))
71d35b24 CD	331	(unless e
	332	(condition-case nil
	333	(org-end-of-subtree t t)
	334	(error (goto-char (point-max))))
	335	(setq e (point)))
20908596 CD	336	(goto-char b)
	337	(unless (re-search-forward
	338	(concat "^" (regexp-quote leader)
	339	"[ \t]*"
	340	org-archive-sibling-heading
	341	"[ \t]*:"
	342	org-archive-tag ":") e t)
	343	(goto-char e)
	344	(or (bolp) (newline))
	345	(insert leader org-archive-sibling-heading "\n")
	346	(beginning-of-line 0)
	347	(org-toggle-tag org-archive-tag 'on))
	348	(beginning-of-line 1)
	349	(org-end-of-subtree t t)
	350	(save-excursion
	351	(goto-char pos)
ff4be292	352	(let ((this-command this-command)) (org-cut-subtree)))
20908596 CD	353	(org-paste-subtree (org-get-valid-level level 1))
	354	(org-set-property
	355	"ARCHIVE_TIME"
	356	(format-time-string
	357	(substring (cdr org-time-stamp-formats) 1 -1)
	358	(current-time)))
	359	(outline-up-heading 1 t)
	360	(hide-subtree)
621f83e4	361	(org-cycle-show-empty-lines 'folded)
0bd48b37 CD	362	(goto-char pos)))
0bd48b37 CD	363	(org-reveal))
20908596 CD	364
	365	(defun org-archive-all-done (&optional tag)
	366	"Archive sublevels of the current tree without open TODO items.
	367	If the cursor is not on a headline, try all level 1 trees. If
	368	it is on a headline, try all direct children.
	369	When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
	370	(let ((re (concat "^\\*+ +" org-not-done-regexp)) re1
	371	(rea (concat ".*:" org-archive-tag ":"))
	372	(begm (make-marker))
	373	(endm (make-marker))
	374	(question (if tag "Set ARCHIVE tag (no open TODO items)? "
	375	"Move subtree to archive (no open TODO items)? "))
	376	beg end (cntarch 0))
	377	(if (org-on-heading-p)
	378	(progn
	379	(setq re1 (concat "^" (regexp-quote
	380	(make-string
	381	(1+ (- (match-end 0) (match-beginning 0) 1))
	382	?*))
	383	" "))
	384	(move-marker begm (point))
	385	(move-marker endm (org-end-of-subtree t)))
	386	(setq re1 "^* ")
	387	(move-marker begm (point-min))
	388	(move-marker endm (point-max)))
	389	(save-excursion
	390	(goto-char begm)
	391	(while (re-search-forward re1 endm t)
	392	(setq beg (match-beginning 0)
	393	end (save-excursion (org-end-of-subtree t) (point)))
	394	(goto-char beg)
	395	(if (re-search-forward re end t)
	396	(goto-char end)
	397	(goto-char beg)
	398	(if (and (or (not tag) (not (looking-at rea)))
	399	(y-or-n-p question))
	400	(progn
	401	(if tag
	402	(org-toggle-tag org-archive-tag 'on)
	403	(org-archive-subtree))
	404	(setq cntarch (1+ cntarch)))
	405	(goto-char end)))))
	406	(message "%d trees archived" cntarch)))
	407
	408	(defun org-toggle-archive-tag (&optional find-done)
	409	"Toggle the archive tag for the current headline.
	410	With prefix ARG, check all children of current headline and offer tagging
	411	the children that do not contain any open TODO items."
	412	(interactive "P")
	413	(if find-done
	414	(org-archive-all-done 'tag)
	415	(let (set)
	416	(save-excursion
	417	(org-back-to-heading t)
	418	(setq set (org-toggle-tag org-archive-tag))
	419	(when set (hide-subtree)))
	420	(and set (beginning-of-line 1))
	421	(message "Subtree %s" (if set "archived" "unarchived")))))
	422
	423	(provide 'org-archive)
	424
88ac7b50	425	;; arch-tag: 0837f601-9699-43c3-8b90-631572ae6c85
b349f79f	426
20908596	427	;;; org-archive.el ends here