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