diff options
Diffstat (limited to 'lisp/org/org-archive.el')
| -rw-r--r-- | lisp/org/org-archive.el | 425 |
1 files changed, 242 insertions, 183 deletions
diff --git a/lisp/org/org-archive.el b/lisp/org/org-archive.el index 39a6581046a..ce1f35df365 100644 --- a/lisp/org/org-archive.el +++ b/lisp/org/org-archive.el @@ -1,4 +1,4 @@ -;;; org-archive.el --- Archiving for Org-mode +;;; org-archive.el --- Archiving for Org -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2017 Free Software Foundation, Inc. @@ -29,10 +29,10 @@ ;;; Code: (require 'org) -(eval-when-compile (require 'cl)) -(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) +(declare-function org-element-type "org-element" (element)) (declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction)) +(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) (defcustom org-archive-default-command 'org-archive-subtree "The default archiving command." @@ -57,7 +57,7 @@ See `org-archive-to-archive-sibling' for more information." (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 +This can be a string to set the keyword to use. When non-nil, Org will use the first keyword in its list that means done." :group 'org-archive :type '(choice @@ -120,9 +120,15 @@ information." (const :tag "Outline path" olpath) (const :tag "Local tags" ltags))) +(defvar org-archive-hook nil + "Hook run after successfully archiving a subtree. +Hook functions are called with point on the subtree in the +original file. At this stage, the subtree has been added to the +archive location, but not yet deleted from the original file.") + (defun org-get-local-archive-location () "Get the archive location applicable at point." - (let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") + (let ((re "^[ \t]*#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") prop) (save-excursion (save-restriction @@ -154,21 +160,24 @@ archive file is." (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) - (pushnew file files :test #'equal))))) + (let ((case-fold-search t) + files) + (org-with-wide-buffer + (goto-char (point-min)) + (while (re-search-forward + "^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)" + nil t) + (when (save-match-data + (if (eq (match-string 1) ":") (org-at-property-p) + (eq (org-element-type (org-element-at-point)) 'keyword))) + (let ((file (org-extract-archive-file + (match-string-no-properties 2)))) + (when (and (org-string-nw-p file) (file-exists-p file)) + (push file files)))))) (setq files (nreverse files)) - (setq file (org-extract-archive-file)) - (and file (> (length file) 0) (file-exists-p file) - (pushnew file files :test #'equal)) + (let ((file (org-extract-archive-file))) + (when (and (org-string-nw-p file) (file-exists-p file)) + (push file files))) files)) (defun org-extract-archive-file (&optional location) @@ -195,15 +204,19 @@ if LOCATION is not given, the value of `org-archive-location' is used." ;;;###autoload (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." +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 a single prefix argument FIND-DONE, find whole +trees without any open TODO items and archive them (after getting +confirmation from the user). When called with a double prefix +argument, find whole trees with timestamps before today and +archive them (after getting confirmation from the user). If the +cursor is not at a headline when these commands are called, try +all level 1 trees. If the cursor is on a headline, only try the +direct children of this heading." (interactive "P") (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) (let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level) @@ -213,46 +226,36 @@ this heading." `(progn (setq org-map-continue-from (progn (org-back-to-heading) (point))) (org-archive-subtree ,find-done)) org-loop-over-headlines-in-active-region - cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) - (if find-done - (org-archive-all-done) + cl (if (org-invisible-p) (org-end-of-subtree nil t)))) + (cond + ((equal find-done '(4)) (org-archive-all-done)) + ((equal find-done '(16)) (org-archive-all-old)) + (t ;; 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 - (or (buffer-file-name (buffer-base-buffer)) - (error "No file associated to buffer")))) - (olpath (mapconcat 'identity (org-get-outline-path) "/")) - (time (format-time-string - (substring (cdr org-time-stamp-formats) 1 -1))) - category todo priority ltags itags atags - ;; end of variables that will be used for saving context - location afile heading buffer level newfile-p infile-p visiting - datetree-date datetree-subheading-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) - infile-p (equal file (abbreviate-file-name (or afile "")))) - (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)) + (let* ((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)) + (time (format-time-string + (substring (cdr org-time-stamp-formats) 1 -1))) + (file (abbreviate-file-name + (or (buffer-file-name (buffer-base-buffer)) + (error "No file associated to buffer")))) + (location (org-get-local-archive-location)) + (afile (or (org-extract-archive-file location) + (error "Invalid `org-archive-location'"))) + (heading (org-extract-archive-heading location)) + (infile-p (equal file (abbreviate-file-name (or afile "")))) + (newfile-p (and (org-string-nw-p afile) + (not (file-exists-p afile)))) + (buffer (cond ((not (org-string-nw-p afile)) this-buffer) + ((find-buffer-visiting afile)) + ((find-file-noselect afile)) + (t (error "Cannot access file \"%s\"" afile)))) + level datetree-date datetree-subheading-p) (when (string-match "\\`datetree/" heading) ;; Replace with ***, to represent the 3 levels of headings the ;; datetree has. @@ -266,108 +269,120 @@ this heading." (setq heading nil level 0)) (save-excursion (org-back-to-heading t) - ;; Get context information that will be lost by moving the tree - (setq category (org-get-category nil 'force-refresh) - 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)) - atags (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 (derived-mode-p 'org-mode)) - ;; Force the mode for future visits. - (let ((org-insert-mode-line-in-empty-file t) - (org-inhibit-startup t)) - (call-interactively 'org-mode))) - (when (and newfile-p org-archive-file-header-format) - (goto-char (point-max)) - (insert (format org-archive-file-header-format - (buffer-file-name this-buffer)))) - (when datetree-date - (require 'org-datetree) - (org-datetree-find-date-create datetree-date) - (org-narrow-to-subtree)) - ;; 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 (and heading (not (and datetree-date (not datetree-subheading-p)))) - (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")) - ;; datetrees don't need too much spacing - (insert (if datetree-date "" "\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]*") - ;; datetree archives don't need so much spacing. - (replace-match (if datetree-date "\n" "\n\n")))) - ;; No specific heading, just go to end of file. - (goto-char (point-max)) (unless datetree-date (insert "\n"))) - ;; Paste - (org-paste-subtree (org-get-valid-level level (and heading 1))) - ;; Shall we append inherited tags? - (and itags - (or (and (eq org-archive-subtree-add-inherited-tags 'infile) - infile-p) - (eq org-archive-subtree-add-inherited-tags t)) - (org-set-tags-to atags)) - ;; 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))))) - - (widen) - ;; 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. + ;; Get context information that will be lost by moving the + ;; tree. See `org-archive-save-context-info'. + (let* ((all-tags (org-get-tags-at)) + (local-tags (org-get-tags)) + (inherited-tags (org-delete-all local-tags all-tags)) + (context + `((category . ,(org-get-category nil 'force-refresh)) + (file . ,file) + (itags . ,(mapconcat #'identity inherited-tags " ")) + (ltags . ,(mapconcat #'identity local-tags " ")) + (olpath . ,(mapconcat #'identity + (org-get-outline-path) + "/")) + (time . ,time) + (todo . ,(org-entry-get (point) "TODO"))))) + ;; 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 (derived-mode-p 'org-mode)) + ;; Force the mode for future visits. + (let ((org-insert-mode-line-in-empty-file t) + (org-inhibit-startup t)) + (call-interactively 'org-mode))) + (when (and newfile-p org-archive-file-header-format) + (goto-char (point-max)) + (insert (format org-archive-file-header-format + (buffer-file-name this-buffer)))) + (when datetree-date + (require 'org-datetree) + (org-datetree-find-date-create datetree-date) + (org-narrow-to-subtree)) + ;; 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)) + (outline-show-all) + (if (and heading (not (and datetree-date (not datetree-subheading-p)))) + (progn + (if (re-search-forward + (concat "^" (regexp-quote heading) + "[ \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")) + ;; datetrees don't need too much spacing + (insert (if datetree-date "" "\n") heading "\n") + (end-of-line 0)) + ;; Make the subtree visible + (outline-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]*") + ;; datetree archives don't need so much spacing. + (replace-match (if datetree-date "\n" "\n\n")))) + ;; No specific heading, just go to end of file. + (goto-char (point-max)) + ;; Subtree narrowing can let the buffer end on + ;; a headline. `org-paste-subtree' then deletes it. + ;; To prevent this, make sure visible part of buffer + ;; always terminates on a new line, while limiting + ;; number of blank lines in a date tree. + (unless (and datetree-date (bolp)) (insert "\n"))) + ;; Paste + (org-paste-subtree (org-get-valid-level level (and heading 1))) + ;; Shall we append inherited tags? + (and inherited-tags + (or (and (eq org-archive-subtree-add-inherited-tags 'infile) + infile-p) + (eq org-archive-subtree-add-inherited-tags t)) + (org-set-tags-to all-tags)) + ;; Mark the entry as done + (when (and org-archive-mark-done + (let ((case-fold-search nil)) + (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. + (dolist (item org-archive-save-context-info) + (let ((value (cdr (assq item context)))) + (when (org-string-nw-p value) + (org-entry-put + (point) + (concat "ARCHIVE_" (upcase (symbol-name item))) + value)))) + (widen) + ;; Save and kill the buffer, if it is not the same + ;; buffer. + (unless (eq this-buffer buffer) (save-buffer))))) + ;; Here we are back in the original buffer. Everything seems + ;; to have worked. So now run hooks, cut the tree and finish + ;; up. + (run-hooks 'org-archive-hook) (let (this-command) (org-cut-subtree)) (when (featurep 'org-inlinetask) (org-inlinetask-remove-END-maybe)) @@ -375,7 +390,7 @@ this heading." (message "Subtree archived %s" (if (eq this-buffer buffer) (concat "under heading: " heading) - (concat "in file: " (abbreviate-file-name afile)))))) + (concat "in file: " (abbreviate-file-name afile))))))) (org-reveal) (if (looking-at "^[ \t]*$") (outline-next-visible-heading 1)))) @@ -383,9 +398,12 @@ this heading." ;;;###autoload (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." +sibling does not exist, it will be created at the end of the subtree. + +Archiving time is retained in the ARCHIVE_TIME node property." (interactive) (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) (let ((cl (when (eq org-loop-over-headlines-in-active-region 'start-level) @@ -400,7 +418,7 @@ sibling does not exist, it will be created at the end of the subtree." (when (org-at-heading-p) (org-archive-to-archive-sibling))) org-loop-over-headlines-in-active-region - cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) + cl (if (org-invisible-p) (org-end-of-subtree nil t)))) (save-restriction (widen) (let (b e pos leader level) @@ -443,7 +461,7 @@ sibling does not exist, it will be created at the end of the subtree." (format-time-string (substring (cdr org-time-stamp-formats) 1 -1))) (outline-up-heading 1 t) - (hide-subtree) + (outline-hide-subtree) (org-cycle-show-empty-lines 'folded) (goto-char pos))) (org-reveal) @@ -455,13 +473,51 @@ sibling does not exist, it will be created at the end of the subtree." 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 org-not-done-heading-regexp) re1 - (rea (concat ".*:" org-archive-tag ":")) + (org-archive-all-matches + (lambda (_beg end) + (let ((case-fold-search nil)) + (unless (re-search-forward org-not-done-heading-regexp end t) + "no open TODO items"))) + tag)) + +(defun org-archive-all-old (&optional tag) + "Archive sublevels of the current tree with timestamps prior to today. +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." + (org-archive-all-matches + (lambda (_beg end) + (let (ts) + (and (re-search-forward org-ts-regexp end t) + (setq ts (match-string 0)) + (< (org-time-stamp-to-now ts) 0) + (if (not (looking-at + (concat "--\\(" org-ts-regexp "\\)"))) + (concat "old timestamp " ts) + (setq ts (concat "old timestamp " ts (match-string 0))) + (and (< (org-time-stamp-to-now (match-string 1)) 0) + ts))))) + tag)) + +(defun org-archive-all-matches (predicate &optional tag) + "Archive sublevels of the current tree that match PREDICATE. + +PREDICATE is a function of two arguments, BEG and END, which +specify the beginning and end of the headline being considered. +It is called with point positioned at BEG. The headline will be +archived if PREDICATE returns non-nil. If the return value of +PREDICATE is a string, it should describe the reason for +archiving the heading. + +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 ((rea (concat ".*:" org-archive-tag ":")) re1 (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)) + (question (if tag "Set ARCHIVE tag? " + "Move subtree to archive? ")) + reason beg end (cntarch 0)) (if (org-at-heading-p) (progn (setq re1 (concat "^" (regexp-quote @@ -481,11 +537,14 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag." (setq beg (match-beginning 0) end (save-excursion (org-end-of-subtree t) (point))) (goto-char beg) - (if (re-search-forward re end t) + (if (not (setq reason (funcall predicate beg end))) (goto-char end) (goto-char beg) (if (and (or (not tag) (not (looking-at rea))) - (y-or-n-p question)) + (y-or-n-p + (if (stringp reason) + (concat question "(" reason ")") + question))) (progn (if tag (org-toggle-tag org-archive-tag 'on) @@ -507,14 +566,14 @@ the children that do not contain any open TODO items." (org-map-entries `(org-toggle-archive-tag ,find-done) org-loop-over-headlines-in-active-region - cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) + cl (if (org-invisible-p) (org-end-of-subtree nil t)))) (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))) + (when set (org-flag-subtree t))) (and set (beginning-of-line 1)) (message "Subtree %s" (if set "archived" "unarchived")))))) @@ -528,7 +587,7 @@ the children that do not contain any open TODO items." (org-map-entries 'org-archive-set-tag org-loop-over-headlines-in-active-region - cl (if (outline-invisible-p) (org-end-of-subtree nil t)))) + cl (if (org-invisible-p) (org-end-of-subtree nil t)))) (org-toggle-tag org-archive-tag 'on))) ;;;###autoload |