lisp/org-archive.el

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