| commit | author | age | ||
| 76bbd0 | 1 | ;;; org-archive.el --- Archiving for Org -*- lexical-binding: t; -*- |
| C | 2 | |
| 3 | ;; Copyright (C) 2004-2018 Free Software Foundation, Inc. | |
| 4 | ||
| 5 | ;; Author: Carsten Dominik <carsten at orgmode dot org> | |
| 6 | ;; Keywords: outlines, hypermedia, calendar, wp | |
| 7 | ;; Homepage: https://orgmode.org | |
| 8 | ;; | |
| 9 | ;; This file is part of GNU Emacs. | |
| 10 | ;; | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| 12 | ;; it under the terms of the GNU General Public License as published by | |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or | |
| 14 | ;; (at your option) any later version. | |
| 15 | ||
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 19 | ;; GNU General Public License for more details. | |
| 20 | ||
| 21 | ;; You should have received a copy of the GNU General Public License | |
| 22 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 24 | ;; | |
| 25 | ;;; Commentary: | |
| 26 | ||
| 27 | ;; This file contains the face definitions for Org. | |
| 28 | ||
| 29 | ;;; Code: | |
| 30 | ||
| 31 | (require 'org) | |
| 32 | ||
| 33 | (declare-function org-element-type "org-element" (element)) | |
| 34 | (declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction)) | |
| 35 | (declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) | |
| 36 | ||
| 37 | (defcustom org-archive-default-command 'org-archive-subtree | |
| 38 | "The default archiving command." | |
| 39 | :group 'org-archive | |
| 40 | :type '(choice | |
| 41 | (const org-archive-subtree) | |
| 42 | (const org-archive-to-archive-sibling) | |
| 43 | (const org-archive-set-tag))) | |
| 44 | ||
| 45 | (defcustom org-archive-reversed-order nil | |
| 46 | "Non-nil means make the tree first child under the archive heading, not last." | |
| 47 | :group 'org-archive | |
| 48 | :version "24.1" | |
| 49 | :type 'boolean) | |
| 50 | ||
| 51 | (defcustom org-archive-sibling-heading "Archive" | |
| 52 | "Name of the local archive sibling that is used to archive entries locally. | |
| 53 | Locally means: in the tree, under a sibling. | |
| 54 | See `org-archive-to-archive-sibling' for more information." | |
| 55 | :group 'org-archive | |
| 56 | :type 'string) | |
| 57 | ||
| 58 | (defcustom org-archive-mark-done nil | |
| 59 | "Non-nil means mark entries as DONE when they are moved to the archive file. | |
| 60 | This can be a string to set the keyword to use. When non-nil, Org will | |
| 61 | use the first keyword in its list that means done." | |
| 62 | :group 'org-archive | |
| 63 | :type '(choice | |
| 64 | (const :tag "No" nil) | |
| 65 | (const :tag "Yes" t) | |
| 66 | (string :tag "Use this keyword"))) | |
| 67 | ||
| 68 | (defcustom org-archive-stamp-time t | |
| 69 | "Non-nil means add a time stamp to entries moved to an archive file. | |
| 70 | This variable is obsolete and has no effect anymore, instead add or remove | |
| 71 | `time' from the variable `org-archive-save-context-info'." | |
| 72 | :group 'org-archive | |
| 73 | :type 'boolean) | |
| 74 | ||
| 75 | (defcustom org-archive-file-header-format "\nArchived entries from file %s\n\n" | |
| 76 | "The header format string for newly created archive files. | |
| 77 | When nil, no header will be inserted. | |
| 78 | When a string, a %s formatter will be replaced by the file name." | |
| 79 | :group 'org-archive | |
| 80 | :version "24.4" | |
| 81 | :package-version '(Org . "8.0") | |
| 82 | :type 'string) | |
| 83 | ||
| 84 | (defcustom org-archive-subtree-add-inherited-tags 'infile | |
| 85 | "Non-nil means append inherited tags when archiving a subtree." | |
| 86 | :group 'org-archive | |
| 87 | :version "24.1" | |
| 88 | :type '(choice | |
| 89 | (const :tag "Never" nil) | |
| 90 | (const :tag "When archiving a subtree to the same file" infile) | |
| 91 | (const :tag "Always" t))) | |
| 92 | ||
| 93 | (defcustom org-archive-save-context-info '(time file olpath category todo itags) | |
| 94 | "Parts of context info that should be stored as properties when archiving. | |
| 95 | When a subtree is moved to an archive file, it loses information given by | |
| 96 | context, like inherited tags, the category, and possibly also the TODO | |
| 97 | state (depending on the variable `org-archive-mark-done'). | |
| 98 | This variable can be a list of any of the following symbols: | |
| 99 | ||
| 100 | time The time of archiving. | |
| 101 | file The file where the entry originates. | |
| 102 | ltags The local tags, in the headline of the subtree. | |
| 103 | itags The tags the subtree inherits from further up the hierarchy. | |
| 104 | todo The pre-archive TODO state. | |
| 105 | category The category, taken from file name or #+CATEGORY lines. | |
| 106 | olpath The outline path to the item. These are all headlines above | |
| 107 | the current item, separated by /, like a file path. | |
| 108 | ||
| 109 | For each symbol present in the list, a property will be created in | |
| 110 | the archived entry, with a prefix \"ARCHIVE_\", to remember this | |
| 111 | information." | |
| 112 | :group 'org-archive | |
| 113 | :type '(set :greedy t | |
| 114 | (const :tag "Time" time) | |
| 115 | (const :tag "File" file) | |
| 116 | (const :tag "Category" category) | |
| 117 | (const :tag "TODO state" todo) | |
| 118 | (const :tag "Priority" priority) | |
| 119 | (const :tag "Inherited tags" itags) | |
| 120 | (const :tag "Outline path" olpath) | |
| 121 | (const :tag "Local tags" ltags))) | |
| 122 | ||
| 123 | (defvar org-archive-hook nil | |
| 124 | "Hook run after successfully archiving a subtree. | |
| 125 | Hook functions are called with point on the subtree in the | |
| 126 | original file. At this stage, the subtree has been added to the | |
| 127 | archive location, but not yet deleted from the original file.") | |
| 128 | ||
| 129 | (defun org-get-local-archive-location () | |
| 130 | "Get the archive location applicable at point." | |
| 131 | (let ((re "^[ \t]*#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") | |
| 132 | prop) | |
| 133 | (save-excursion | |
| 134 | (save-restriction | |
| 135 | (widen) | |
| 136 | (setq prop (org-entry-get nil "ARCHIVE" 'inherit)) | |
| 137 | (cond | |
| 138 | ((and prop (string-match "\\S-" prop)) | |
| 139 | prop) | |
| 140 | ((or (re-search-backward re nil t) | |
| 141 | (re-search-forward re nil t)) | |
| 142 | (match-string 1)) | |
| 143 | (t org-archive-location)))))) | |
| 144 | ||
| 145 | ;;;###autoload | |
| 146 | (defun org-add-archive-files (files) | |
| 147 | "Splice the archive files into the list of files. | |
| 148 | This implies visiting all these files and finding out what the | |
| 149 | archive file is." | |
| 150 | (org-uniquify | |
| 151 | (apply | |
| 152 | 'append | |
| 153 | (mapcar | |
| 154 | (lambda (f) | |
| 155 | (if (not (file-exists-p f)) | |
| 156 | nil | |
| 157 | (with-current-buffer (org-get-agenda-file-buffer f) | |
| 158 | (cons f (org-all-archive-files))))) | |
| 159 | files)))) | |
| 160 | ||
| 161 | (defun org-all-archive-files () | |
| 162 | "Get a list of all archive files used in the current buffer." | |
| 163 | (let ((case-fold-search t) | |
| 164 | files) | |
| 165 | (org-with-wide-buffer | |
| 166 | (goto-char (point-min)) | |
| 167 | (while (re-search-forward | |
| 168 | "^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)" | |
| 169 | nil t) | |
| 170 | (when (save-match-data | |
| 171 | (if (eq (match-string 1) ":") (org-at-property-p) | |
| 172 | (eq (org-element-type (org-element-at-point)) 'keyword))) | |
| 173 | (let ((file (org-extract-archive-file | |
| 174 | (match-string-no-properties 2)))) | |
| 175 | (when (and (org-string-nw-p file) (file-exists-p file)) | |
| 176 | (push file files)))))) | |
| 177 | (setq files (nreverse files)) | |
| 178 | (let ((file (org-extract-archive-file))) | |
| 179 | (when (and (org-string-nw-p file) (file-exists-p file)) | |
| 180 | (push file files))) | |
| 181 | files)) | |
| 182 | ||
| 183 | (defun org-extract-archive-file (&optional location) | |
| 184 | "Extract and expand the file name from archive LOCATION. | |
| 185 | if LOCATION is not given, the value of `org-archive-location' is used." | |
| 186 | (setq location (or location org-archive-location)) | |
| 187 | (if (string-match "\\(.*\\)::\\(.*\\)" location) | |
| 188 | (if (= (match-beginning 1) (match-end 1)) | |
| 189 | (buffer-file-name (buffer-base-buffer)) | |
| 190 | (expand-file-name | |
| 191 | (format (match-string 1 location) | |
| 192 | (file-name-nondirectory | |
| 193 | (buffer-file-name (buffer-base-buffer)))))))) | |
| 194 | ||
| 195 | (defun org-extract-archive-heading (&optional location) | |
| 196 | "Extract the heading from archive LOCATION. | |
| 197 | if LOCATION is not given, the value of `org-archive-location' is used." | |
| 198 | (setq location (or location org-archive-location)) | |
| 199 | (if (string-match "\\(.*\\)::\\(.*\\)" location) | |
| 200 | (format (match-string 2 location) | |
| 201 | (file-name-nondirectory | |
| 202 | (buffer-file-name (buffer-base-buffer)))))) | |
| 203 | ||
| 204 | ;;;###autoload | |
| 205 | (defun org-archive-subtree (&optional find-done) | |
| 206 | "Move the current subtree to the archive. | |
| 207 | The archive can be a certain top-level heading in the current | |
| 208 | file, or in a different file. The tree will be moved to that | |
| 209 | location, the subtree heading be marked DONE, and the current | |
| 210 | time will be added. | |
| 211 | ||
| 212 | When called with a single prefix argument FIND-DONE, find whole | |
| 213 | trees without any open TODO items and archive them (after getting | |
| 214 | confirmation from the user). When called with a double prefix | |
| 215 | argument, find whole trees with timestamps before today and | |
| 216 | archive them (after getting confirmation from the user). If the | |
| 217 | cursor is not at a headline when these commands are called, try | |
| 218 | all level 1 trees. If the cursor is on a headline, only try the | |
| 219 | direct children of this heading." | |
| 220 | (interactive "P") | |
| 221 | (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) | |
| 222 | (let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level) | |
| 223 | 'region-start-level 'region)) | |
| 224 | org-loop-over-headlines-in-active-region) | |
| 225 | (org-map-entries | |
| 226 | `(progn (setq org-map-continue-from (progn (org-back-to-heading) (point))) | |
| 227 | (org-archive-subtree ,find-done)) | |
| 228 | org-loop-over-headlines-in-active-region | |
| 229 | cl (if (org-invisible-p) (org-end-of-subtree nil t)))) | |
| 230 | (cond | |
| 231 | ((equal find-done '(4)) (org-archive-all-done)) | |
| 232 | ((equal find-done '(16)) (org-archive-all-old)) | |
| 233 | (t | |
| 234 | ;; Save all relevant TODO keyword-relatex variables | |
| 235 | (let* ((tr-org-todo-keywords-1 org-todo-keywords-1) | |
| 236 | (tr-org-todo-kwd-alist org-todo-kwd-alist) | |
| 237 | (tr-org-done-keywords org-done-keywords) | |
| 238 | (tr-org-todo-regexp org-todo-regexp) | |
| 239 | (tr-org-todo-line-regexp org-todo-line-regexp) | |
| 240 | (tr-org-odd-levels-only org-odd-levels-only) | |
| 241 | (this-buffer (current-buffer)) | |
| 242 | (time (format-time-string | |
| 243 | (substring (cdr org-time-stamp-formats) 1 -1))) | |
| 244 | (file (abbreviate-file-name | |
| 245 | (or (buffer-file-name (buffer-base-buffer)) | |
| 246 | (error "No file associated to buffer")))) | |
| 247 | (location (org-get-local-archive-location)) | |
| 248 | (afile (or (org-extract-archive-file location) | |
| 249 | (error "Invalid `org-archive-location'"))) | |
| 250 | (heading (org-extract-archive-heading location)) | |
| 251 | (infile-p (equal file (abbreviate-file-name (or afile "")))) | |
| 252 | (newfile-p (and (org-string-nw-p afile) | |
| 253 | (not (file-exists-p afile)))) | |
| 254 | (buffer (cond ((not (org-string-nw-p afile)) this-buffer) | |
| 255 | ((find-buffer-visiting afile)) | |
| 256 | ((find-file-noselect afile)) | |
| 257 | (t (error "Cannot access file \"%s\"" afile)))) | |
| 258 | level datetree-date datetree-subheading-p) | |
| 259 | (when (string-match "\\`datetree/" heading) | |
| 260 | ;; Replace with ***, to represent the 3 levels of headings the | |
| 261 | ;; datetree has. | |
| 262 | (setq heading (replace-regexp-in-string "\\`datetree/" "***" heading)) | |
| 263 | (setq datetree-subheading-p (> (length heading) 3)) | |
| 264 | (setq datetree-date (org-date-to-gregorian | |
| 265 | (or (org-entry-get nil "CLOSED" t) time)))) | |
| 266 | (if (and (> (length heading) 0) | |
| 267 | (string-match "^\\*+" heading)) | |
| 268 | (setq level (match-end 0)) | |
| 269 | (setq heading nil level 0)) | |
| 270 | (save-excursion | |
| 271 | (org-back-to-heading t) | |
| 272 | ;; Get context information that will be lost by moving the | |
| 273 | ;; tree. See `org-archive-save-context-info'. | |
| 274 | (let* ((all-tags (org-get-tags-at)) | |
| 275 | (local-tags (org-get-tags)) | |
| 276 | (inherited-tags (org-delete-all local-tags all-tags)) | |
| 277 | (context | |
| 278 | `((category . ,(org-get-category nil 'force-refresh)) | |
| 279 | (file . ,file) | |
| 280 | (itags . ,(mapconcat #'identity inherited-tags " ")) | |
| 281 | (ltags . ,(mapconcat #'identity local-tags " ")) | |
| 282 | (olpath . ,(mapconcat #'identity | |
| 283 | (org-get-outline-path) | |
| 284 | "/")) | |
| 285 | (time . ,time) | |
| 286 | (todo . ,(org-entry-get (point) "TODO"))))) | |
| 287 | ;; We first only copy, in case something goes wrong | |
| 288 | ;; we need to protect `this-command', to avoid kill-region sets it, | |
| 289 | ;; which would lead to duplication of subtrees | |
| 290 | (let (this-command) (org-copy-subtree 1 nil t)) | |
| 291 | (set-buffer buffer) | |
| 292 | ;; Enforce Org mode for the archive buffer | |
| 293 | (if (not (derived-mode-p 'org-mode)) | |
| 294 | ;; Force the mode for future visits. | |
| 295 | (let ((org-insert-mode-line-in-empty-file t) | |
| 296 | (org-inhibit-startup t)) | |
| 297 | (call-interactively 'org-mode))) | |
| 298 | (when (and newfile-p org-archive-file-header-format) | |
| 299 | (goto-char (point-max)) | |
| 300 | (insert (format org-archive-file-header-format | |
| 301 | (buffer-file-name this-buffer)))) | |
| 302 | (when datetree-date | |
| 303 | (require 'org-datetree) | |
| 304 | (org-datetree-find-date-create datetree-date) | |
| 305 | (org-narrow-to-subtree)) | |
| 306 | ;; Force the TODO keywords of the original buffer | |
| 307 | (let ((org-todo-line-regexp tr-org-todo-line-regexp) | |
| 308 | (org-todo-keywords-1 tr-org-todo-keywords-1) | |
| 309 | (org-todo-kwd-alist tr-org-todo-kwd-alist) | |
| 310 | (org-done-keywords tr-org-done-keywords) | |
| 311 | (org-todo-regexp tr-org-todo-regexp) | |
| 312 | (org-todo-line-regexp tr-org-todo-line-regexp) | |
| 313 | (org-odd-levels-only | |
| 314 | (if (local-variable-p 'org-odd-levels-only (current-buffer)) | |
| 315 | org-odd-levels-only | |
| 316 | tr-org-odd-levels-only))) | |
| 317 | (goto-char (point-min)) | |
| 318 | (outline-show-all) | |
| 319 | (if (and heading (not (and datetree-date (not datetree-subheading-p)))) | |
| 320 | (progn | |
| 321 | (if (re-search-forward | |
| 322 | (concat "^" (regexp-quote heading) | |
| 323 | "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)") | |
| 324 | nil t) | |
| 325 | (goto-char (match-end 0)) | |
| 326 | ;; Heading not found, just insert it at the end | |
| 327 | (goto-char (point-max)) | |
| 328 | (or (bolp) (insert "\n")) | |
| 329 | ;; datetrees don't need too much spacing | |
| 330 | (insert (if datetree-date "" "\n") heading "\n") | |
| 331 | (end-of-line 0)) | |
| 332 | ;; Make the subtree visible | |
| 333 | (outline-show-subtree) | |
| 334 | (if org-archive-reversed-order | |
| 335 | (progn | |
| 336 | (org-back-to-heading t) | |
| 337 | (outline-next-heading)) | |
| 338 | (org-end-of-subtree t)) | |
| 339 | (skip-chars-backward " \t\r\n") | |
| 340 | (and (looking-at "[ \t\r\n]*") | |
| 341 | ;; datetree archives don't need so much spacing. | |
| 342 | (replace-match (if datetree-date "\n" "\n\n")))) | |
| 343 | ;; No specific heading, just go to end of file, or to the | |
| 344 | ;; beginning, depending on `org-archive-reversed-order'. | |
| 345 | (if org-archive-reversed-order | |
| 346 | (progn | |
| 347 | (goto-char (point-min)) | |
| 348 | (unless (org-at-heading-p) (outline-next-heading)) | |
| 349 | (insert "\n") (backward-char 1)) | |
| 350 | (goto-char (point-max)) | |
| 351 | ;; Subtree narrowing can let the buffer end on | |
| 352 | ;; a headline. `org-paste-subtree' then deletes it. | |
| 353 | ;; To prevent this, make sure visible part of buffer | |
| 354 | ;; always terminates on a new line, while limiting | |
| 355 | ;; number of blank lines in a date tree. | |
| 356 | (unless (and datetree-date (bolp)) (insert "\n")))) | |
| 357 | ;; Paste | |
| 358 | (org-paste-subtree (org-get-valid-level level (and heading 1))) | |
| 359 | ;; Shall we append inherited tags? | |
| 360 | (and inherited-tags | |
| 361 | (or (and (eq org-archive-subtree-add-inherited-tags 'infile) | |
| 362 | infile-p) | |
| 363 | (eq org-archive-subtree-add-inherited-tags t)) | |
| 364 | (org-set-tags-to all-tags)) | |
| 365 | ;; Mark the entry as done | |
| 366 | (when (and org-archive-mark-done | |
| 367 | (let ((case-fold-search nil)) | |
| 368 | (looking-at org-todo-line-regexp)) | |
| 369 | (or (not (match-end 2)) | |
| 370 | (not (member (match-string 2) org-done-keywords)))) | |
| 371 | (let (org-log-done org-todo-log-states) | |
| 372 | (org-todo | |
| 373 | (car (or (member org-archive-mark-done org-done-keywords) | |
| 374 | org-done-keywords))))) | |
| 375 | ||
| 376 | ;; Add the context info. | |
| 377 | (dolist (item org-archive-save-context-info) | |
| 378 | (let ((value (cdr (assq item context)))) | |
| 379 | (when (org-string-nw-p value) | |
| 380 | (org-entry-put | |
| 381 | (point) | |
| 382 | (concat "ARCHIVE_" (upcase (symbol-name item))) | |
| 383 | value)))) | |
| 384 | (widen)))) | |
| 385 | ;; Here we are back in the original buffer. Everything seems | |
| 386 | ;; to have worked. So now run hooks, cut the tree and finish | |
| 387 | ;; up. | |
| 388 | (run-hooks 'org-archive-hook) | |
| 389 | (let (this-command) (org-cut-subtree)) | |
| 390 | (when (featurep 'org-inlinetask) | |
| 391 | (org-inlinetask-remove-END-maybe)) | |
| 392 | (setq org-markers-to-move nil) | |
| 393 | (message "Subtree archived %s" | |
| 394 | (if (eq this-buffer buffer) | |
| 395 | (concat "under heading: " heading) | |
| 396 | (concat "in file: " (abbreviate-file-name afile))))))) | |
| 397 | (org-reveal) | |
| 398 | (if (looking-at "^[ \t]*$") | |
| 399 | (outline-next-visible-heading 1)))) | |
| 400 | ||
| 401 | ;;;###autoload | |
| 402 | (defun org-archive-to-archive-sibling () | |
| 403 | "Archive the current heading by moving it under the archive sibling. | |
| 404 | ||
| 405 | The archive sibling is a sibling of the heading with the heading name | |
| 406 | `org-archive-sibling-heading' and an `org-archive-tag' tag. If this | |
| 407 | sibling does not exist, it will be created at the end of the subtree. | |
| 408 | ||
| 409 | Archiving time is retained in the ARCHIVE_TIME node property." | |
| 410 | (interactive) | |
| 411 | (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) | |
| 412 | (let ((cl (when (eq org-loop-over-headlines-in-active-region 'start-level) | |
| 413 | 'region-start-level 'region)) | |
| 414 | org-loop-over-headlines-in-active-region) | |
| 415 | (org-map-entries | |
| 416 | '(progn (setq org-map-continue-from | |
| 417 | (progn (org-back-to-heading) | |
| 418 | (if (looking-at (concat "^.*:" org-archive-tag ":.*$")) | |
| 419 | (org-end-of-subtree t) | |
| 420 | (point)))) | |
| 421 | (when (org-at-heading-p) | |
| 422 | (org-archive-to-archive-sibling))) | |
| 423 | org-loop-over-headlines-in-active-region | |
| 424 | cl (if (org-invisible-p) (org-end-of-subtree nil t)))) | |
| 425 | (save-restriction | |
| 426 | (widen) | |
| 427 | (let (b e pos leader level) | |
| 428 | (org-back-to-heading t) | |
| 429 | (looking-at org-outline-regexp) | |
| 430 | (setq leader (match-string 0) | |
| 431 | level (funcall outline-level)) | |
| 432 | (setq pos (point-marker)) | |
| 433 | (condition-case nil | |
| 434 | (outline-up-heading 1 t) | |
| 435 | (error (setq e (point-max)) (goto-char (point-min)))) | |
| 436 | (setq b (point)) | |
| 437 | (unless e | |
| 438 | (condition-case nil | |
| 439 | (org-end-of-subtree t t) | |
| 440 | (error (goto-char (point-max)))) | |
| 441 | (setq e (point))) | |
| 442 | (goto-char b) | |
| 443 | (unless (re-search-forward | |
| 444 | (concat "^" (regexp-quote leader) | |
| 445 | "[ \t]*" | |
| 446 | org-archive-sibling-heading | |
| 447 | "[ \t]*:" | |
| 448 | org-archive-tag ":") e t) | |
| 449 | (goto-char e) | |
| 450 | (or (bolp) (newline)) | |
| 451 | (insert leader org-archive-sibling-heading "\n") | |
| 452 | (beginning-of-line 0) | |
| 453 | (org-toggle-tag org-archive-tag 'on)) | |
| 454 | (beginning-of-line 1) | |
| 455 | (if org-archive-reversed-order | |
| 456 | (outline-next-heading) | |
| 457 | (org-end-of-subtree t t)) | |
| 458 | (save-excursion | |
| 459 | (goto-char pos) | |
| 460 | (let ((this-command this-command)) (org-cut-subtree))) | |
| 461 | (org-paste-subtree (org-get-valid-level level 1)) | |
| 462 | (org-set-property | |
| 463 | "ARCHIVE_TIME" | |
| 464 | (format-time-string | |
| 465 | (substring (cdr org-time-stamp-formats) 1 -1))) | |
| 466 | (outline-up-heading 1 t) | |
| 467 | (outline-hide-subtree) | |
| 468 | (org-cycle-show-empty-lines 'folded) | |
| 469 | (goto-char pos))) | |
| 470 | (org-reveal) | |
| 471 | (if (looking-at "^[ \t]*$") | |
| 472 | (outline-next-visible-heading 1)))) | |
| 473 | ||
| 474 | (defun org-archive-all-done (&optional tag) | |
| 475 | "Archive sublevels of the current tree without open TODO items. | |
| 476 | If the cursor is not on a headline, try all level 1 trees. If | |
| 477 | it is on a headline, try all direct children. | |
| 478 | When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag." | |
| 479 | (org-archive-all-matches | |
| 480 | (lambda (_beg end) | |
| 481 | (let ((case-fold-search nil)) | |
| 482 | (unless (re-search-forward org-not-done-heading-regexp end t) | |
| 483 | "no open TODO items"))) | |
| 484 | tag)) | |
| 485 | ||
| 486 | (defun org-archive-all-old (&optional tag) | |
| 487 | "Archive sublevels of the current tree with timestamps prior to today. | |
| 488 | If the cursor is not on a headline, try all level 1 trees. If | |
| 489 | it is on a headline, try all direct children. | |
| 490 | When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag." | |
| 491 | (org-archive-all-matches | |
| 492 | (lambda (_beg end) | |
| 493 | (let (ts) | |
| 494 | (and (re-search-forward org-ts-regexp end t) | |
| 495 | (setq ts (match-string 0)) | |
| 496 | (< (org-time-stamp-to-now ts) 0) | |
| 497 | (if (not (looking-at | |
| 498 | (concat "--\\(" org-ts-regexp "\\)"))) | |
| 499 | (concat "old timestamp " ts) | |
| 500 | (setq ts (concat "old timestamp " ts (match-string 0))) | |
| 501 | (and (< (org-time-stamp-to-now (match-string 1)) 0) | |
| 502 | ts))))) | |
| 503 | tag)) | |
| 504 | ||
| 505 | (defun org-archive-all-matches (predicate &optional tag) | |
| 506 | "Archive sublevels of the current tree that match PREDICATE. | |
| 507 | ||
| 508 | PREDICATE is a function of two arguments, BEG and END, which | |
| 509 | specify the beginning and end of the headline being considered. | |
| 510 | It is called with point positioned at BEG. The headline will be | |
| 511 | archived if PREDICATE returns non-nil. If the return value of | |
| 512 | PREDICATE is a string, it should describe the reason for | |
| 513 | archiving the heading. | |
| 514 | ||
| 515 | If the cursor is not on a headline, try all level 1 trees. If it | |
| 516 | is on a headline, try all direct children. When TAG is non-nil, | |
| 517 | don't move trees, but mark them with the ARCHIVE tag." | |
| 518 | (let ((rea (concat ".*:" org-archive-tag ":")) re1 | |
| 519 | (begm (make-marker)) | |
| 520 | (endm (make-marker)) | |
| 521 | (question (if tag "Set ARCHIVE tag? " | |
| 522 | "Move subtree to archive? ")) | |
| 523 | reason beg end (cntarch 0)) | |
| 524 | (if (org-at-heading-p) | |
| 525 | (progn | |
| 526 | (setq re1 (concat "^" (regexp-quote | |
| 527 | (make-string | |
| 528 | (+ (- (match-end 0) (match-beginning 0) 1) | |
| 529 | (if org-odd-levels-only 2 1)) | |
| 530 | ?*)) | |
| 531 | " ")) | |
| 532 | (move-marker begm (point)) | |
| 533 | (move-marker endm (org-end-of-subtree t))) | |
| 534 | (setq re1 "^* ") | |
| 535 | (move-marker begm (point-min)) | |
| 536 | (move-marker endm (point-max))) | |
| 537 | (save-excursion | |
| 538 | (goto-char begm) | |
| 539 | (while (re-search-forward re1 endm t) | |
| 540 | (setq beg (match-beginning 0) | |
| 541 | end (save-excursion (org-end-of-subtree t) (point))) | |
| 542 | (goto-char beg) | |
| 543 | (if (not (setq reason (funcall predicate beg end))) | |
| 544 | (goto-char end) | |
| 545 | (goto-char beg) | |
| 546 | (if (and (or (not tag) (not (looking-at rea))) | |
| 547 | (y-or-n-p | |
| 548 | (if (stringp reason) | |
| 549 | (concat question "(" reason ")") | |
| 550 | question))) | |
| 551 | (progn | |
| 552 | (if tag | |
| 553 | (org-toggle-tag org-archive-tag 'on) | |
| 554 | (org-archive-subtree)) | |
| 555 | (setq cntarch (1+ cntarch))) | |
| 556 | (goto-char end))))) | |
| 557 | (message "%d trees archived" cntarch))) | |
| 558 | ||
| 559 | ;;;###autoload | |
| 560 | (defun org-toggle-archive-tag (&optional find-done) | |
| 561 | "Toggle the archive tag for the current headline. | |
| 562 | With prefix ARG, check all children of current headline and offer tagging | |
| 563 | the children that do not contain any open TODO items." | |
| 564 | (interactive "P") | |
| 565 | (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) | |
| 566 | (let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level) | |
| 567 | 'region-start-level 'region)) | |
| 568 | org-loop-over-headlines-in-active-region) | |
| 569 | (org-map-entries | |
| 570 | `(org-toggle-archive-tag ,find-done) | |
| 571 | org-loop-over-headlines-in-active-region | |
| 572 | cl (if (org-invisible-p) (org-end-of-subtree nil t)))) | |
| 573 | (if find-done | |
| 574 | (org-archive-all-done 'tag) | |
| 575 | (let (set) | |
| 576 | (save-excursion | |
| 577 | (org-back-to-heading t) | |
| 578 | (setq set (org-toggle-tag org-archive-tag)) | |
| 579 | (when set (org-flag-subtree t))) | |
| 580 | (and set (beginning-of-line 1)) | |
| 581 | (message "Subtree %s" (if set "archived" "unarchived")))))) | |
| 582 | ||
| 583 | (defun org-archive-set-tag () | |
| 584 | "Set the ARCHIVE tag." | |
| 585 | (interactive) | |
| 586 | (if (and (org-region-active-p) org-loop-over-headlines-in-active-region) | |
| 587 | (let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level) | |
| 588 | 'region-start-level 'region)) | |
| 589 | org-loop-over-headlines-in-active-region) | |
| 590 | (org-map-entries | |
| 591 | 'org-archive-set-tag | |
| 592 | org-loop-over-headlines-in-active-region | |
| 593 | cl (if (org-invisible-p) (org-end-of-subtree nil t)))) | |
| 594 | (org-toggle-tag org-archive-tag 'on))) | |
| 595 | ||
| 596 | ;;;###autoload | |
| 597 | (defun org-archive-subtree-default () | |
| 598 | "Archive the current subtree with the default command. | |
| 599 | This command is set with the variable `org-archive-default-command'." | |
| 600 | (interactive) | |
| 601 | (call-interactively org-archive-default-command)) | |
| 602 | ||
| 603 | ;;;###autoload | |
| 604 | (defun org-archive-subtree-default-with-confirmation () | |
| 605 | "Archive the current subtree with the default command. | |
| 606 | This command is set with the variable `org-archive-default-command'." | |
| 607 | (interactive) | |
| 608 | (if (y-or-n-p "Archive this subtree or entry? ") | |
| 609 | (call-interactively org-archive-default-command) | |
| 610 | (error "Abort"))) | |
| 611 | ||
| 612 | (provide 'org-archive) | |
| 613 | ||
| 614 | ;; Local variables: | |
| 615 | ;; generated-autoload-file: "org-loaddefs.el" | |
| 616 | ;; End: | |
| 617 | ||
| 618 | ;;; org-archive.el ends here | |
