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.02
   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-sibling-heading "Archive"
  37   "Name of the local archive sibling that is used to archive entries locally.
  38 Locally means: in the tree, under a sibling.
  39 See `org-archive-to-archive-sibling' for more information."
  40   :group 'org-archive
  41   :type 'string)
  42
  43 (defcustom org-archive-mark-done t
  44   "Non-nil means, mark entries as DONE when they are moved to the archive file.
  45 This can be a string to set the keyword to use.  When t, Org-mode will
  46 use the first keyword in its list that means done."
  47   :group 'org-archive
  48   :type '(choice
  49           (const :tag "No" nil)
  50           (const :tag "Yes" t)
  51           (string :tag "Use this keyword")))
  52
  53 (defcustom org-archive-stamp-time t
  54   "Non-nil means, add a time stamp to entries moved to an archive file.
  55 This variable is obsolete and has no effect anymore, instead add ot remove
  56 `time' from the variablle `org-archive-save-context-info'."
  57   :group 'org-archive
  58   :type 'boolean)
  59
  60 (defcustom org-archive-save-context-info '(time file olpath category todo itags)
  61   "Parts of context info that should be stored as properties when archiving.
  62 When a subtree is moved to an archive file, it looses information given by
  63 context, like inherited tags, the category, and possibly also the TODO
  64 state (depending on the variable `org-archive-mark-done').
  65 This variable can be a list of any of the following symbols:
  66
  67 time       The time of archiving.
  68 file       The file where the entry originates.
  69 itags      The local tags, in the headline of the subtree.
  70 ltags      The tags the subtree inherits from further up the hierarchy.
  71 todo       The pre-archive TODO state.
  72 category   The category, taken from file name or #+CATEGORY lines.
  73 olpath     The outline path to the item.  These are all headlines above
  74            the current item, separated by /, like a file path.
  75
  76 For each symbol present in the list, a property will be created in
  77 the archived entry, with a prefix \"PRE_ARCHIVE_\", to remember this
  78 information."
  79   :group 'org-archive
  80   :type '(set :greedy t
  81           (const :tag "Time" time)
  82           (const :tag "File" file)
  83           (const :tag "Category" category)
  84           (const :tag "TODO state" todo)
  85           (const :tag "TODO state" priority)
  86           (const :tag "Inherited tags" itags)
  87           (const :tag "Outline path" olpath)
  88           (const :tag "Local tags" ltags)))
  89
  90 (defun org-get-local-archive-location ()
  91   "Get the archive location applicable at point."
  92   (let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
  93         prop)
  94     (save-excursion
  95       (save-restriction
  96         (widen)
  97         (setq prop (org-entry-get nil "ARCHIVE" 'inherit))
  98         (cond
  99          ((and prop (string-match "\\S-" prop))
 100           prop)
 101          ((or (re-search-backward re nil t)
 102               (re-search-forward re nil t))
 103           (match-string 1))
 104          (t org-archive-location (match-string 1)))))))
 105
 106 (defun org-add-archive-files (files)
 107   "Splice the archive files into the list f files.
 108 This implies visiting all these files and finding out what the
 109 archive file is."
 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)))
 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)
 140   (setq location (or location org-archive-location))
 141   (if (string-match "\\(.*\\)::\\(.*\\)" location)
 142       (if (= (match-beginning 1) (match-end 1))
 143           (buffer-file-name)
 144         (expand-file-name
 145          (format (match-string 1 location) buffer-file-name)))))
 146
 147 (defun org-extract-archive-heading (&optional location)
 148   (setq location (or location org-archive-location))
 149   (if (string-match "\\(.*\\)::\\(.*\\)" location)
 150       (match-string 2 location)))
 151
 152 (defun org-archive-subtree (&optional find-done)
 153   "Move the current subtree to the archive.
 154 The archive can be a certain top-level heading in the current file, or in
 155 a different file.  The tree will be moved to that location, the subtree
 156 heading be marked DONE, and the current time will be added.
 157
 158 When called with prefix argument FIND-DONE, find whole trees without any
 159 open TODO items and archive them (after getting confirmation from the user).
 160 If the cursor is not at a headline when this comand is called, try all level
 161 1 trees.  If the cursor is on a headline, only try the direct children of
 162 this heading."
 163   (interactive "P")
 164   (if find-done
 165       (org-archive-all-done)
 166     ;; Save all relevant TODO keyword-relatex variables
 167
 168     (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
 169           (tr-org-todo-keywords-1 org-todo-keywords-1)
 170           (tr-org-todo-kwd-alist org-todo-kwd-alist)
 171           (tr-org-done-keywords org-done-keywords)
 172           (tr-org-todo-regexp org-todo-regexp)
 173           (tr-org-todo-line-regexp org-todo-line-regexp)
 174           (tr-org-odd-levels-only org-odd-levels-only)
 175           (this-buffer (current-buffer))
 176           ;; start of variables that will be used for saving context
 177           ;; The compiler complains about them - keep them anyway!
 178           (file (abbreviate-file-name (buffer-file-name)))
 179           (olpath (mapconcat 'identity (org-get-outline-path) "/"))
 180           (time (format-time-string
 181                  (substring (cdr org-time-stamp-formats) 1 -1)
 182                  (current-time)))
 183           category todo priority ltags itags
 184           ;; end of variables that will be used for saving context
 185           location afile heading buffer level newfile-p)
 186
 187       ;; Find the local archive location
 188       (setq location (org-get-local-archive-location)
 189             afile (org-extract-archive-file location)
 190             heading (org-extract-archive-heading location))
 191       (unless afile
 192         (error "Invalid `org-archive-location'"))
 193
 194       (if (> (length afile) 0)
 195           (setq newfile-p (not (file-exists-p afile))
 196                 buffer (find-file-noselect afile))
 197         (setq buffer (current-buffer)))
 198       (unless buffer
 199         (error "Cannot access file \"%s\"" afile))
 200       (if (and (> (length heading) 0)
 201                (string-match "^\\*+" heading))
 202           (setq level (match-end 0))
 203         (setq heading nil level 0))
 204       (save-excursion
 205         (org-back-to-heading t)
 206         ;; Get context information that will be lost by moving the tree
 207         (org-refresh-category-properties)
 208         (setq category (org-get-category)
 209               todo (and (looking-at org-todo-line-regexp)
 210                         (match-string 2))
 211               priority (org-get-priority
 212                         (if (match-end 3) (match-string 3) ""))
 213               ltags (org-get-tags)
 214               itags (org-delete-all ltags (org-get-tags-at)))
 215         (setq ltags (mapconcat 'identity ltags " ")
 216               itags (mapconcat 'identity itags " "))
 217         ;; We first only copy, in case something goes wrong
 218         ;; we need to protect this-command, to avoid kill-region sets it,
 219         ;; which would lead to duplication of subtrees
 220         (let (this-command) (org-copy-subtree))
 221         (set-buffer buffer)
 222         ;; Enforce org-mode for the archive buffer
 223         (if (not (org-mode-p))
 224             ;; Force the mode for future visits.
 225             (let ((org-insert-mode-line-in-empty-file t)
 226                   (org-inhibit-startup t))
 227               (call-interactively 'org-mode)))
 228         (when newfile-p
 229           (goto-char (point-max))
 230           (insert (format "\nArchived entries from file %s\n\n"
 231                           (buffer-file-name this-buffer))))
 232         ;; Force the TODO keywords of the original buffer
 233         (let ((org-todo-line-regexp tr-org-todo-line-regexp)
 234               (org-todo-keywords-1 tr-org-todo-keywords-1)
 235               (org-todo-kwd-alist tr-org-todo-kwd-alist)
 236               (org-done-keywords tr-org-done-keywords)
 237               (org-todo-regexp tr-org-todo-regexp)
 238               (org-todo-line-regexp tr-org-todo-line-regexp)
 239               (org-odd-levels-only
 240                (if (local-variable-p 'org-odd-levels-only (current-buffer))
 241                    org-odd-levels-only
 242                  tr-org-odd-levels-only)))
 243           (goto-char (point-min))
 244           (show-all)
 245           (if heading
 246               (progn
 247                 (if (re-search-forward
 248                      (concat "^" (regexp-quote heading)
 249                              (org-re "[ \t]*\\(:[[:alnum:]_@:]+:\\)?[ \t]*\\($\\|\r\\)"))
 250                      nil t)
 251                     (goto-char (match-end 0))
 252                   ;; Heading not found, just insert it at the end
 253                   (goto-char (point-max))
 254                   (or (bolp) (insert "\n"))
 255                   (insert "\n" heading "\n")
 256                   (end-of-line 0))
 257                 ;; Make the subtree visible
 258                 (show-subtree)
 259                 (org-end-of-subtree t)
 260                 (skip-chars-backward " \t\r\n")
 261                 (and (looking-at "[ \t\r\n]*")
 262                      (replace-match "\n\n")))
 263             ;; No specific heading, just go to end of file.
 264             (goto-char (point-max)) (insert "\n"))
 265           ;; Paste
 266           (org-paste-subtree (org-get-valid-level level 1))
 267
 268           ;; Mark the entry as done
 269           (when (and org-archive-mark-done
 270                      (looking-at org-todo-line-regexp)
 271                      (or (not (match-end 2))
 272                          (not (member (match-string 2) org-done-keywords))))
 273             (let (org-log-done org-todo-log-states)
 274               (org-todo
 275                (car (or (member org-archive-mark-done org-done-keywords)
 276                         org-done-keywords)))))
 277
 278           ;; Add the context info
 279           (when org-archive-save-context-info
 280             (let ((l org-archive-save-context-info) e n v)
 281               (while (setq e (pop l))
 282                 (when (and (setq v (symbol-value e))
 283                            (stringp v) (string-match "\\S-" v))
 284                   (setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
 285                   (org-entry-put (point) n v)))))
 286
 287           ;; Save and kill the buffer, if it is not the same buffer.
 288           (if (not (eq this-buffer buffer))
 289               (progn (save-buffer) (kill-buffer buffer)))))
 290       ;; Here we are back in the original buffer.  Everything seems to have
 291       ;; worked.  So now cut the tree and finish up.
 292       (let (this-command) (org-cut-subtree))
 293       (if (and (not (eobp)) (looking-at "[ \t]*$")) (kill-line))
 294       (message "Subtree archived %s"
 295                (if (eq this-buffer buffer)
 296                    (concat "under heading: " heading)
 297                  (concat "in file: " (abbreviate-file-name afile)))))))
 298
 299 (defun org-archive-to-archive-sibling ()
 300   "Archive the current heading by moving it under the archive sibling.
 301 The archive sibling is a sibling of the heading with the heading name
 302 `org-archive-sibling-heading' and an `org-archive-tag' tag.  If this
 303 sibling does not exist, it will be created at the end of the subtree."
 304   (interactive)
 305   (save-restriction
 306     (widen)
 307     (let (b e pos leader level)
 308       (org-back-to-heading t)
 309       (looking-at outline-regexp)
 310       (setq leader (match-string 0)
 311             level (funcall outline-level))
 312       (setq pos (point))
 313       (condition-case nil
 314           (outline-up-heading 1 t)
 315         (error (goto-char (point-min))))
 316       (setq b (point))
 317       (condition-case nil
 318           (org-end-of-subtree t t)
 319         (error (goto-char (point-max))))
 320       (setq e (point))
 321       (goto-char b)
 322       (unless (re-search-forward
 323                (concat "^" (regexp-quote leader)
 324                        "[ \t]*"
 325                        org-archive-sibling-heading
 326                        "[ \t]*:"
 327                        org-archive-tag ":") e t)
 328         (goto-char e)
 329         (or (bolp) (newline))
 330         (insert leader org-archive-sibling-heading "\n")
 331         (beginning-of-line 0)
 332         (org-toggle-tag org-archive-tag 'on))
 333       (beginning-of-line 1)
 334       (org-end-of-subtree t t)
 335       (save-excursion
 336         (goto-char pos)
 337         (org-cut-subtree))
 338       (org-paste-subtree (org-get-valid-level level 1))
 339       (org-set-property
 340        "ARCHIVE_TIME"
 341        (format-time-string
 342         (substring (cdr org-time-stamp-formats) 1 -1)
 343         (current-time)))
 344       (outline-up-heading 1 t)
 345       (hide-subtree)
 346       (goto-char pos))))
 347
 348 (defun org-archive-all-done (&optional tag)
 349   "Archive sublevels of the current tree without open TODO items.
 350 If the cursor is not on a headline, try all level 1 trees.  If
 351 it is on a headline, try all direct children.
 352 When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
 353   (let ((re (concat "^\\*+ +" org-not-done-regexp)) re1
 354         (rea (concat ".*:" org-archive-tag ":"))
 355         (begm (make-marker))
 356         (endm (make-marker))
 357         (question (if tag "Set ARCHIVE tag (no open TODO items)? "
 358                     "Move subtree to archive (no open TODO items)? "))
 359         beg end (cntarch 0))
 360     (if (org-on-heading-p)
 361         (progn
 362           (setq re1 (concat "^" (regexp-quote
 363                                  (make-string
 364                                   (1+ (- (match-end 0) (match-beginning 0) 1))
 365                                   ?*))
 366                             " "))
 367           (move-marker begm (point))
 368           (move-marker endm (org-end-of-subtree t)))
 369       (setq re1 "^* ")
 370       (move-marker begm (point-min))
 371       (move-marker endm (point-max)))
 372     (save-excursion
 373       (goto-char begm)
 374       (while (re-search-forward re1 endm t)
 375         (setq beg (match-beginning 0)
 376               end (save-excursion (org-end-of-subtree t) (point)))
 377         (goto-char beg)
 378         (if (re-search-forward re end t)
 379             (goto-char end)
 380           (goto-char beg)
 381           (if (and (or (not tag) (not (looking-at rea)))
 382                    (y-or-n-p question))
 383               (progn
 384                 (if tag
 385                     (org-toggle-tag org-archive-tag 'on)
 386                   (org-archive-subtree))
 387                 (setq cntarch (1+ cntarch)))
 388             (goto-char end)))))
 389     (message "%d trees archived" cntarch)))
 390
 391 (defun org-toggle-archive-tag (&optional find-done)
 392   "Toggle the archive tag for the current headline.
 393 With prefix ARG, check all children of current headline and offer tagging
 394 the children that do not contain any open TODO items."
 395   (interactive "P")
 396   (if find-done
 397       (org-archive-all-done 'tag)
 398     (let (set)
 399       (save-excursion
 400         (org-back-to-heading t)
 401         (setq set (org-toggle-tag org-archive-tag))
 402         (when set (hide-subtree)))
 403       (and set (beginning-of-line 1))
 404       (message "Subtree %s" (if set "archived" "unarchived")))))
 405
 406 (provide 'org-archive)
 407
 408 ;;; org-archive.el ends here