From f7464fdd2e33e5dc6c159a4adc8f53902e6d4511 Mon Sep 17 00:00:00 2001 From: Luke Shumaker Date: Wed, 13 Apr 2011 23:20:15 -0400 Subject: Initial commit of Luke Shumaker's "dot-files". --- .emacs.d/org-7.4/lisp/org-archive.el | 471 +++++++++++++++++++++++++++++++++++ 1 file changed, 471 insertions(+) create mode 100644 .emacs.d/org-7.4/lisp/org-archive.el (limited to '.emacs.d/org-7.4/lisp/org-archive.el') diff --git a/.emacs.d/org-7.4/lisp/org-archive.el b/.emacs.d/org-7.4/lisp/org-archive.el new file mode 100644 index 0000000..e56b01f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-archive.el @@ -0,0 +1,471 @@ +;;; org-archive.el --- Archiving for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; 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 of the License, 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. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the face definitions for Org. + +;;; Code: + +(require 'org) + +(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) + +(defcustom org-archive-default-command 'org-archive-subtree + "The default archiving command." + :group 'org-archive + :type '(choice + (const org-archive-subtree) + (const org-archive-to-archive-sibling) + (const org-archive-set-tag))) + +(defcustom org-archive-reversed-order nil + "Non-nil means make the tree first child under the archive heading, not last." + :group 'org-archive + :type 'boolean) + +(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 nil + "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 or remove +`time' from the variable `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 loses 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. +ltags The local tags, in the headline of the subtree. +itags 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 "Priority" 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)))))) + +(defun org-add-archive-files (files) + "Splice the archive files into the list of files. +This implies visiting all these files and finding out what the +archive file is." + (org-uniquify + (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) + "Extract and expand the file name from archive LOCATION. +if LOCATION is not given, the value of `org-archive-location' is used." + (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) + (file-name-nondirectory buffer-file-name)))))) + +(defun org-extract-archive-heading (&optional location) + "Extract the heading from archive LOCATION. +if LOCATION is not given, the value of `org-archive-location' is used." + (setq location (or location org-archive-location)) + (if (string-match "\\(.*\\)::\\(.*\\)" location) + (format (match-string 2 location) + (file-name-nondirectory buffer-file-name)))) + +(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 command 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 visiting) + + ;; 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)) + visiting (find-buffer-visiting afile) + buffer (or visiting (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 1 nil t)) + (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) + (if org-archive-reversed-order + (progn + (org-back-to-heading t) + (outline-next-heading)) + (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 (and heading 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. + (when (not (eq this-buffer buffer)) + (save-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)) + (when (featurep 'org-inlinetask) + (org-inlinetask-remove-END-maybe)) + (setq org-markers-to-move nil) + (message "Subtree archived %s" + (if (eq this-buffer buffer) + (concat "under heading: " heading) + (concat "in file: " (abbreviate-file-name afile)))))) + (org-reveal) + (if (looking-at "^[ \t]*$") + (outline-next-visible-heading 1))) + +(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 (setq e (point-max)) (goto-char (point-min)))) + (setq b (point)) + (unless e + (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) + (if org-archive-reversed-order + (outline-next-heading) + (org-end-of-subtree t t)) + (save-excursion + (goto-char pos) + (let ((this-command this-command)) (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) + (org-cycle-show-empty-lines 'folded) + (goto-char pos))) + (org-reveal) + (if (looking-at "^[ \t]*$") + (outline-next-visible-heading 1))) + +(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 + (+ (- (match-end 0) (match-beginning 0) 1) + (if org-odd-levels-only 2 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"))))) + +(defun org-archive-set-tag () + "Set the ARCHIVE tag." + (interactive) + (org-toggle-tag org-archive-tag 'on)) + +;;;###autoload +(defun org-archive-subtree-default () + "Archive the current subtree with the default command. +This command is set with the variable `org-archive-default-command'." + (interactive) + (call-interactively org-archive-default-command)) + +;;;###autoload +(defun org-archive-subtree-default-with-confirmation () + "Archive the current subtree with the default command. +This command is set with the variable `org-archive-default-command'." + (interactive) + (if (y-or-n-p "Archive this subtree or entry? ") + (call-interactively org-archive-default-command) + (error "Abort"))) + +(provide 'org-archive) + +;; arch-tag: 0837f601-9699-43c3-8b90-631572ae6c85 + +;;; org-archive.el ends here -- cgit v1.2.3-54-g00ecf