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.01a
   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 (defalias 'org-advertized-archive-subtree 'org-archive-subtree)
 133
 134 (defun org-archive-subtree (&optional find-done)
 135   "Move the current subtree to the archive.
 136 The archive can be a certain top-level heading in the current file, or in
 137 a different file.  The tree will be moved to that location, the subtree
 138 heading be marked DONE, and the current time will be added.
 139
 140 When called with prefix argument FIND-DONE, find whole trees without any
 141 open TODO items and archive them (after getting confirmation from the user).
 142 If the cursor is not at a headline when this comand is called, try all level
 143 1 trees.  If the cursor is on a headline, only try the direct children of
 144 this heading."
 145   (interactive "P")
 146   (if find-done
 147       (org-archive-all-done)
 148     ;; Save all relevant TODO keyword-relatex variables
 149
 150     (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
 151           (tr-org-todo-keywords-1 org-todo-keywords-1)
 152           (tr-org-todo-kwd-alist org-todo-kwd-alist)
 153           (tr-org-done-keywords org-done-keywords)
 154           (tr-org-todo-regexp org-todo-regexp)
 155           (tr-org-todo-line-regexp org-todo-line-regexp)
 156           (tr-org-odd-levels-only org-odd-levels-only)
 157           (this-buffer (current-buffer))
 158           (org-archive-location org-archive-location)
 159           (re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
 160           ;; start of variables that will be used for saving context
 161           ;; The compiler complains about them - keep them anyway!
 162           (file (abbreviate-file-name (buffer-file-name)))
 163           (olpath (mapconcat 'identity (org-get-outline-path) "/"))
 164           (time (format-time-string
 165                  (substring (cdr org-time-stamp-formats) 1 -1)
 166                  (current-time)))
 167           afile heading buffer level newfile-p
 168           category todo priority
 169           ;; start of variables that will be used for savind context
 170           ltags itags prop)
 171
 172       ;; Try to find a local archive location
 173       (save-excursion
 174         (save-restriction
 175           (widen)
 176           (setq prop (org-entry-get nil "ARCHIVE" 'inherit))
 177           (if (and prop (string-match "\\S-" prop))
 178               (setq org-archive-location prop)
 179             (if (or (re-search-backward re nil t)
 180                     (re-search-forward re nil t))
 181                 (setq org-archive-location (match-string 1))))))
 182
 183       (if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location)
 184           (progn
 185             (setq afile (format (match-string 1 org-archive-location)
 186                                 (file-name-nondirectory buffer-file-name))
 187                   heading (match-string 2 org-archive-location)))
 188         (error "Invalid `org-archive-location'"))
 189       (if (> (length afile) 0)
 190           (setq newfile-p (not (file-exists-p afile))
 191                 buffer (find-file-noselect afile))
 192         (setq buffer (current-buffer)))
 193       (unless buffer
 194         (error "Cannot access file \"%s\"" afile))
 195       (if (and (> (length heading) 0)
 196                (string-match "^\\*+" heading))
 197           (setq level (match-end 0))
 198         (setq heading nil level 0))
 199       (save-excursion
 200         (org-back-to-heading t)
 201         ;; Get context information that will be lost by moving the tree
 202         (org-refresh-category-properties)
 203         (setq category (org-get-category)
 204               todo (and (looking-at org-todo-line-regexp)
 205                         (match-string 2))
 206               priority (org-get-priority
 207                         (if (match-end 3) (match-string 3) ""))
 208               ltags (org-get-tags)
 209               itags (org-delete-all ltags (org-get-tags-at)))
 210         (setq ltags (mapconcat 'identity ltags " ")
 211               itags (mapconcat 'identity itags " "))
 212         ;; We first only copy, in case something goes wrong
 213         ;; we need to protect this-command, to avoid kill-region sets it,
 214         ;; which would lead to duplication of subtrees
 215         (let (this-command) (org-copy-subtree))
 216         (set-buffer buffer)
 217         ;; Enforce org-mode for the archive buffer
 218         (if (not (org-mode-p))
 219             ;; Force the mode for future visits.
 220             (let ((org-insert-mode-line-in-empty-file t)
 221                   (org-inhibit-startup t))
 222               (call-interactively 'org-mode)))
 223         (when newfile-p
 224           (goto-char (point-max))
 225           (insert (format "\nArchived entries from file %s\n\n"
 226                           (buffer-file-name this-buffer))))
 227         ;; Force the TODO keywords of the original buffer
 228         (let ((org-todo-line-regexp tr-org-todo-line-regexp)
 229               (org-todo-keywords-1 tr-org-todo-keywords-1)
 230               (org-todo-kwd-alist tr-org-todo-kwd-alist)
 231               (org-done-keywords tr-org-done-keywords)
 232               (org-todo-regexp tr-org-todo-regexp)
 233               (org-todo-line-regexp tr-org-todo-line-regexp)
 234               (org-odd-levels-only
 235                (if (local-variable-p 'org-odd-levels-only (current-buffer))
 236                    org-odd-levels-only
 237                  tr-org-odd-levels-only)))
 238           (goto-char (point-min))
 239           (show-all)
 240           (if heading
 241               (progn
 242                 (if (re-search-forward
 243                      (concat "^" (regexp-quote heading)
 244                              (org-re "[ \t]*\\(:[[:alnum:]_@:]+:\\)?[ \t]*\\($\\|\r\\)"))
 245                      nil t)
 246                     (goto-char (match-end 0))
 247                   ;; Heading not found, just insert it at the end
 248                   (goto-char (point-max))
 249                   (or (bolp) (insert "\n"))
 250                   (insert "\n" heading "\n")
 251                   (end-of-line 0))
 252                 ;; Make the subtree visible
 253                 (show-subtree)
 254                 (org-end-of-subtree t)
 255                 (skip-chars-backward " \t\r\n")
 256                 (and (looking-at "[ \t\r\n]*")
 257                      (replace-match "\n\n")))
 258             ;; No specific heading, just go to end of file.
 259             (goto-char (point-max)) (insert "\n"))
 260           ;; Paste
 261           (org-paste-subtree (org-get-valid-level level 1))
 262
 263           ;; Mark the entry as done
 264           (when (and org-archive-mark-done
 265                      (looking-at org-todo-line-regexp)
 266                      (or (not (match-end 2))
 267                          (not (member (match-string 2) org-done-keywords))))
 268             (let (org-log-done org-todo-log-states)
 269               (org-todo
 270                (car (or (member org-archive-mark-done org-done-keywords)
 271                         org-done-keywords)))))
 272
 273           ;; Add the context info
 274           (when org-archive-save-context-info
 275             (let ((l org-archive-save-context-info) e n v)
 276               (while (setq e (pop l))
 277                 (when (and (setq v (symbol-value e))
 278                            (stringp v) (string-match "\\S-" v))
 279                   (setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
 280                   (org-entry-put (point) n v)))))
 281
 282           ;; Save and kill the buffer, if it is not the same buffer.
 283           (if (not (eq this-buffer buffer))
 284               (progn (save-buffer) (kill-buffer buffer)))))
 285       ;; Here we are back in the original buffer.  Everything seems to have
 286       ;; worked.  So now cut the tree and finish up.
 287       (let (this-command) (org-cut-subtree))
 288       (if (and (not (eobp)) (looking-at "[ \t]*$")) (kill-line))
 289       (message "Subtree archived %s"
 290                (if (eq this-buffer buffer)
 291                    (concat "under heading: " heading)
 292                  (concat "in file: " (abbreviate-file-name afile)))))))
 293
 294 (defun org-archive-to-archive-sibling ()
 295   "Archive the current heading by moving it under the archive sibling.
 296 The archive sibling is a sibling of the heading with the heading name
 297 `org-archive-sibling-heading' and an `org-archive-tag' tag.  If this
 298 sibling does not exist, it will be created at the end of the subtree."
 299   (interactive)
 300   (save-restriction
 301     (widen)
 302     (let (b e pos leader level)
 303       (org-back-to-heading t)
 304       (looking-at outline-regexp)
 305       (setq leader (match-string 0)
 306             level (funcall outline-level))
 307       (setq pos (point))
 308       (condition-case nil
 309           (outline-up-heading 1 t)
 310         (error (goto-char (point-min))))
 311       (setq b (point))
 312       (condition-case nil
 313           (org-end-of-subtree t t)
 314         (error (goto-char (point-max))))
 315       (setq e (point))
 316       (goto-char b)
 317       (unless (re-search-forward
 318                (concat "^" (regexp-quote leader)
 319                        "[ \t]*"
 320                        org-archive-sibling-heading
 321                        "[ \t]*:"
 322                        org-archive-tag ":") e t)
 323         (goto-char e)
 324         (or (bolp) (newline))
 325         (insert leader org-archive-sibling-heading "\n")
 326         (beginning-of-line 0)
 327         (org-toggle-tag org-archive-tag 'on))
 328       (beginning-of-line 1)
 329       (org-end-of-subtree t t)
 330       (save-excursion
 331         (goto-char pos)
 332         (org-cut-subtree))
 333       (org-paste-subtree (org-get-valid-level level 1))
 334       (org-set-property
 335        "ARCHIVE_TIME"
 336        (format-time-string
 337         (substring (cdr org-time-stamp-formats) 1 -1)
 338         (current-time)))
 339       (outline-up-heading 1 t)
 340       (hide-subtree)
 341       (goto-char pos))))
 342
 343 (defun org-archive-all-done (&optional tag)
 344   "Archive sublevels of the current tree without open TODO items.
 345 If the cursor is not on a headline, try all level 1 trees.  If
 346 it is on a headline, try all direct children.
 347 When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
 348   (let ((re (concat "^\\*+ +" org-not-done-regexp)) re1
 349         (rea (concat ".*:" org-archive-tag ":"))
 350         (begm (make-marker))
 351         (endm (make-marker))
 352         (question (if tag "Set ARCHIVE tag (no open TODO items)? "
 353                     "Move subtree to archive (no open TODO items)? "))
 354         beg end (cntarch 0))
 355     (if (org-on-heading-p)
 356         (progn
 357           (setq re1 (concat "^" (regexp-quote
 358                                  (make-string
 359                                   (1+ (- (match-end 0) (match-beginning 0) 1))
 360                                   ?*))
 361                             " "))
 362           (move-marker begm (point))
 363           (move-marker endm (org-end-of-subtree t)))
 364       (setq re1 "^* ")
 365       (move-marker begm (point-min))
 366       (move-marker endm (point-max)))
 367     (save-excursion
 368       (goto-char begm)
 369       (while (re-search-forward re1 endm t)
 370         (setq beg (match-beginning 0)
 371               end (save-excursion (org-end-of-subtree t) (point)))
 372         (goto-char beg)
 373         (if (re-search-forward re end t)
 374             (goto-char end)
 375           (goto-char beg)
 376           (if (and (or (not tag) (not (looking-at rea)))
 377                    (y-or-n-p question))
 378               (progn
 379                 (if tag
 380                     (org-toggle-tag org-archive-tag 'on)
 381                   (org-archive-subtree))
 382                 (setq cntarch (1+ cntarch)))
 383             (goto-char end)))))
 384     (message "%d trees archived" cntarch)))
 385
 386 (defun org-toggle-archive-tag (&optional find-done)
 387   "Toggle the archive tag for the current headline.
 388 With prefix ARG, check all children of current headline and offer tagging
 389 the children that do not contain any open TODO items."
 390   (interactive "P")
 391   (if find-done
 392       (org-archive-all-done 'tag)
 393     (let (set)
 394       (save-excursion
 395         (org-back-to-heading t)
 396         (setq set (org-toggle-tag org-archive-tag))
 397         (when set (hide-subtree)))
 398       (and set (beginning-of-line 1))
 399       (message "Subtree %s" (if set "archived" "unarchived")))))
 400
 401 (provide 'org-archive)
 402
 403 ;;; org-archive.el ends here