[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to org-archive.el
From: |
Carsten Dominik |
Subject: |
[Emacs-diffs] Changes to org-archive.el |
Date: |
Sun, 27 Apr 2008 18:33:43 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Carsten Dominik <cdominik> 08/04/27 18:33:39
Index: org-archive.el
===================================================================
RCS file: org-archive.el
diff -N org-archive.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ org-archive.el 27 Apr 2008 18:33:37 -0000 1.1
@@ -0,0 +1,408 @@
+;;; org-archive.el --- Archiving for Org-mode
+
+;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+
+;; Author: Carsten Dominik <carsten at orgmode dot org>
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 6.02b
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+
+;; This file contains the face definitons for Org.
+
+;;; Code:
+
+(require 'org)
+
+(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.
+See `org-archive-to-archive-sibling' for more information."
+ :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.
+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
+ :type '(choice
+ (const :tag "No" nil)
+ (const :tag "Yes" t)
+ (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.
+This variable is obsolete and has no effect anymore, instead add ot remove
+`time' from the variablle `org-archive-save-context-info'."
+ :group 'org-archive
+ :type 'boolean)
+
+(defcustom org-archive-save-context-info '(time file olpath category todo
itags)
+ "Parts of context info that should be stored as properties when archiving.
+When a subtree is moved to an archive file, it looses information given by
+context, like inherited tags, the category, and possibly also the TODO
+state (depending on the variable `org-archive-mark-done').
+This variable can be a list of any of the following symbols:
+
+time The time of archiving.
+file The file where the entry originates.
+itags The local tags, in the headline of the subtree.
+ltags The tags the subtree inherits from further up the hierarchy.
+todo The pre-archive TODO state.
+category The category, taken from file name or #+CATEGORY lines.
+olpath The outline path to the item. These are all headlines above
+ the current item, separated by /, like a file path.
+
+For each symbol present in the list, a property will be created in
+the archived entry, with a prefix \"PRE_ARCHIVE_\", to remember this
+information."
+ :group 'org-archive
+ :type '(set :greedy t
+ (const :tag "Time" time)
+ (const :tag "File" file)
+ (const :tag "Category" category)
+ (const :tag "TODO state" todo)
+ (const :tag "TODO state" priority)
+ (const :tag "Inherited tags" itags)
+ (const :tag "Outline path" olpath)
+ (const :tag "Local tags" ltags)))
+
+(defun org-get-local-archive-location ()
+ "Get the archive location applicable at point."
+ (let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
+ prop)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (setq prop (org-entry-get nil "ARCHIVE" 'inherit))
+ (cond
+ ((and prop (string-match "\\S-" prop))
+ prop)
+ ((or (re-search-backward re nil t)
+ (re-search-forward re nil t))
+ (match-string 1))
+ (t org-archive-location (match-string 1)))))))
+
+(defun org-add-archive-files (files)
+ "Splice the archive files into the list f 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)))
+
+(defun org-all-archive-files ()
+ "Get a list of all archive files used in the current buffer."
+ (let (file files)
+ (save-excursion
+ (save-restriction
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\(#\\+\\|[ \t]*:\\)ARCHIVE:[ \t]+\\(.*\\)"
+ nil t)
+ (setq file (org-extract-archive-file
+ (org-match-string-no-properties 2)))
+ (and file (> (length file) 0) (file-exists-p file)
+ (add-to-list 'files file)))))
+ (setq files (nreverse files))
+ (setq file (org-extract-archive-file))
+ (and file (> (length file) 0) (file-exists-p file)
+ (add-to-list 'files file))
+ files))
+
+(defun org-extract-archive-file (&optional location)
+ (setq location (or location org-archive-location))
+ (if (string-match "\\(.*\\)::\\(.*\\)" location)
+ (if (= (match-beginning 1) (match-end 1))
+ (buffer-file-name)
+ (expand-file-name
+ (format (match-string 1 location) buffer-file-name)))))
+
+(defun org-extract-archive-heading (&optional location)
+ (setq location (or location org-archive-location))
+ (if (string-match "\\(.*\\)::\\(.*\\)" location)
+ (match-string 2 location)))
+
+(defun org-archive-subtree (&optional find-done)
+ "Move the current subtree to the archive.
+The archive can be a certain top-level heading in the current file, or in
+a different file. The tree will be moved to that location, the subtree
+heading be marked DONE, and the current time will be added.
+
+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
+1 trees. If the cursor is on a headline, only try the direct children of
+this heading."
+ (interactive "P")
+ (if find-done
+ (org-archive-all-done)
+ ;; Save all relevant TODO keyword-relatex variables
+
+ (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite
compiler
+ (tr-org-todo-keywords-1 org-todo-keywords-1)
+ (tr-org-todo-kwd-alist org-todo-kwd-alist)
+ (tr-org-done-keywords org-done-keywords)
+ (tr-org-todo-regexp org-todo-regexp)
+ (tr-org-todo-line-regexp org-todo-line-regexp)
+ (tr-org-odd-levels-only org-odd-levels-only)
+ (this-buffer (current-buffer))
+ ;; start of variables that will be used for saving context
+ ;; The compiler complains about them - keep them anyway!
+ (file (abbreviate-file-name (buffer-file-name)))
+ (olpath (mapconcat 'identity (org-get-outline-path) "/"))
+ (time (format-time-string
+ (substring (cdr org-time-stamp-formats) 1 -1)
+ (current-time)))
+ category todo priority ltags itags
+ ;; end of variables that will be used for saving context
+ location afile heading buffer level newfile-p)
+
+ ;; Find the local archive location
+ (setq location (org-get-local-archive-location)
+ afile (org-extract-archive-file location)
+ heading (org-extract-archive-heading location))
+ (unless afile
+ (error "Invalid `org-archive-location'"))
+
+ (if (> (length afile) 0)
+ (setq newfile-p (not (file-exists-p afile))
+ buffer (find-file-noselect afile))
+ (setq buffer (current-buffer)))
+ (unless buffer
+ (error "Cannot access file \"%s\"" afile))
+ (if (and (> (length heading) 0)
+ (string-match "^\\*+" heading))
+ (setq level (match-end 0))
+ (setq heading nil level 0))
+ (save-excursion
+ (org-back-to-heading t)
+ ;; Get context information that will be lost by moving the tree
+ (org-refresh-category-properties)
+ (setq category (org-get-category)
+ todo (and (looking-at org-todo-line-regexp)
+ (match-string 2))
+ priority (org-get-priority
+ (if (match-end 3) (match-string 3) ""))
+ ltags (org-get-tags)
+ itags (org-delete-all ltags (org-get-tags-at)))
+ (setq ltags (mapconcat 'identity ltags " ")
+ itags (mapconcat 'identity itags " "))
+ ;; We first only copy, in case something goes wrong
+ ;; we need to protect this-command, to avoid kill-region sets it,
+ ;; which would lead to duplication of subtrees
+ (let (this-command) (org-copy-subtree))
+ (set-buffer buffer)
+ ;; Enforce org-mode for the archive buffer
+ (if (not (org-mode-p))
+ ;; Force the mode for future visits.
+ (let ((org-insert-mode-line-in-empty-file t)
+ (org-inhibit-startup t))
+ (call-interactively 'org-mode)))
+ (when newfile-p
+ (goto-char (point-max))
+ (insert (format "\nArchived entries from file %s\n\n"
+ (buffer-file-name this-buffer))))
+ ;; Force the TODO keywords of the original buffer
+ (let ((org-todo-line-regexp tr-org-todo-line-regexp)
+ (org-todo-keywords-1 tr-org-todo-keywords-1)
+ (org-todo-kwd-alist tr-org-todo-kwd-alist)
+ (org-done-keywords tr-org-done-keywords)
+ (org-todo-regexp tr-org-todo-regexp)
+ (org-todo-line-regexp tr-org-todo-line-regexp)
+ (org-odd-levels-only
+ (if (local-variable-p 'org-odd-levels-only (current-buffer))
+ org-odd-levels-only
+ tr-org-odd-levels-only)))
+ (goto-char (point-min))
+ (show-all)
+ (if heading
+ (progn
+ (if (re-search-forward
+ (concat "^" (regexp-quote heading)
+ (org-re "[ \t]*\\(:[[:alnum:]_@:]+:\\)?[
\t]*\\($\\|\r\\)"))
+ nil t)
+ (goto-char (match-end 0))
+ ;; Heading not found, just insert it at the end
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))
+ (insert "\n" heading "\n")
+ (end-of-line 0))
+ ;; Make the subtree visible
+ (show-subtree)
+ (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))
+
+ ;; Mark the entry as done
+ (when (and org-archive-mark-done
+ (looking-at org-todo-line-regexp)
+ (or (not (match-end 2))
+ (not (member (match-string 2) org-done-keywords))))
+ (let (org-log-done org-todo-log-states)
+ (org-todo
+ (car (or (member org-archive-mark-done org-done-keywords)
+ org-done-keywords)))))
+
+ ;; Add the context info
+ (when org-archive-save-context-info
+ (let ((l org-archive-save-context-info) e n v)
+ (while (setq e (pop l))
+ (when (and (setq v (symbol-value e))
+ (stringp v) (string-match "\\S-" v))
+ (setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
+ (org-entry-put (point) n v)))))
+
+ ;; Save and kill the buffer, if it is not the same buffer.
+ (if (not (eq this-buffer buffer))
+ (progn (save-buffer) (kill-buffer 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))
+ (if (and (not (eobp)) (looking-at "[ \t]*$")) (kill-line))
+ (message "Subtree archived %s"
+ (if (eq this-buffer buffer)
+ (concat "under heading: " heading)
+ (concat "in file: " (abbreviate-file-name afile)))))))
+
+(defun org-archive-to-archive-sibling ()
+ "Archive the current heading by moving it under the archive sibling.
+The archive sibling is a sibling of the heading with the heading name
+`org-archive-sibling-heading' and an `org-archive-tag' tag. If this
+sibling does not exist, it will be created at the end of the subtree."
+ (interactive)
+ (save-restriction
+ (widen)
+ (let (b e pos leader level)
+ (org-back-to-heading t)
+ (looking-at outline-regexp)
+ (setq leader (match-string 0)
+ level (funcall outline-level))
+ (setq pos (point))
+ (condition-case nil
+ (outline-up-heading 1 t)
+ (error (goto-char (point-min))))
+ (setq b (point))
+ (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)
+ "[ \t]*"
+ org-archive-sibling-heading
+ "[ \t]*:"
+ org-archive-tag ":") e t)
+ (goto-char e)
+ (or (bolp) (newline))
+ (insert leader org-archive-sibling-heading "\n")
+ (beginning-of-line 0)
+ (org-toggle-tag org-archive-tag 'on))
+ (beginning-of-line 1)
+ (org-end-of-subtree t t)
+ (save-excursion
+ (goto-char pos)
+ (org-cut-subtree))
+ (org-paste-subtree (org-get-valid-level level 1))
+ (org-set-property
+ "ARCHIVE_TIME"
+ (format-time-string
+ (substring (cdr org-time-stamp-formats) 1 -1)
+ (current-time)))
+ (outline-up-heading 1 t)
+ (hide-subtree)
+ (goto-char pos))))
+
+(defun org-archive-all-done (&optional tag)
+ "Archive sublevels of the current tree without open TODO items.
+If the cursor is not on a headline, try all level 1 trees. If
+it is on a headline, try all direct children.
+When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
+ (let ((re (concat "^\\*+ +" org-not-done-regexp)) re1
+ (rea (concat ".*:" org-archive-tag ":"))
+ (begm (make-marker))
+ (endm (make-marker))
+ (question (if tag "Set ARCHIVE tag (no open TODO items)? "
+ "Move subtree to archive (no open TODO items)? "))
+ beg end (cntarch 0))
+ (if (org-on-heading-p)
+ (progn
+ (setq re1 (concat "^" (regexp-quote
+ (make-string
+ (1+ (- (match-end 0) (match-beginning 0) 1))
+ ?*))
+ " "))
+ (move-marker begm (point))
+ (move-marker endm (org-end-of-subtree t)))
+ (setq re1 "^* ")
+ (move-marker begm (point-min))
+ (move-marker endm (point-max)))
+ (save-excursion
+ (goto-char begm)
+ (while (re-search-forward re1 endm t)
+ (setq beg (match-beginning 0)
+ end (save-excursion (org-end-of-subtree t) (point)))
+ (goto-char beg)
+ (if (re-search-forward re end t)
+ (goto-char end)
+ (goto-char beg)
+ (if (and (or (not tag) (not (looking-at rea)))
+ (y-or-n-p question))
+ (progn
+ (if tag
+ (org-toggle-tag org-archive-tag 'on)
+ (org-archive-subtree))
+ (setq cntarch (1+ cntarch)))
+ (goto-char end)))))
+ (message "%d trees archived" cntarch)))
+
+(defun org-toggle-archive-tag (&optional find-done)
+ "Toggle the archive tag for the current headline.
+With prefix ARG, check all children of current headline and offer tagging
+the children that do not contain any open TODO items."
+ (interactive "P")
+ (if find-done
+ (org-archive-all-done 'tag)
+ (let (set)
+ (save-excursion
+ (org-back-to-heading t)
+ (setq set (org-toggle-tag org-archive-tag))
+ (when set (hide-subtree)))
+ (and set (beginning-of-line 1))
+ (message "Subtree %s" (if set "archived" "unarchived")))))
+
+(provide 'org-archive)
+
+;;; org-archive.el ends here
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] Changes to org-archive.el,
Carsten Dominik <=