;;; org-archive.el --- Archiving for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011
+;; Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.05a
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
;;
;;; 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.
+ "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
((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."
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))))
(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")
(progn
(if (re-search-forward
(concat "^" (regexp-quote heading)
- (org-re "[ \t]*\\(:[[:alnum:]_@:]+:\\)?[ \t]*\\($\\|\r\\)"))
+ (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)"))
nil t)
(goto-char (match-end 0))
;; Heading not found, just insert it at the end
(end-of-line 0))
;; Make the subtree visible
(show-subtree)
- (org-end-of-subtree t)
+ (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 1))
+ (org-paste-subtree (org-get-valid-level level (and heading 1)))
;; Mark the entry as done
(when (and org-archive-mark-done
;; 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)))
+ (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)))))))
+ (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.
(setq pos (point))
(condition-case nil
(outline-up-heading 1 t)
- (error (goto-char (point-min))))
+ (error (setq e (point-max)) (goto-char (point-min))))
(setq b (point))
- (condition-case nil
- (org-end-of-subtree t t)
- (error (goto-char (point-max))))
- (setq e (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)
(beginning-of-line 0)
(org-toggle-tag org-archive-tag 'on))
(beginning-of-line 1)
- (org-end-of-subtree t t)
+ (if org-archive-reversed-order
+ (outline-next-heading)
+ (org-end-of-subtree t t))
(save-excursion
(goto-char pos)
- (org-cut-subtree))
+ (let ((this-command this-command)) (org-cut-subtree)))
(org-paste-subtree (org-get-valid-level level 1))
(org-set-property
"ARCHIVE_TIME"
(current-time)))
(outline-up-heading 1 t)
(hide-subtree)
- (goto-char pos))))
+ (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.
(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))
(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))
+
+;;;###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
HCoop / bpt / emacs.git / blobdiff