lisp/org-archive.el

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