org-expiry.el (13451B)
1 ;;; org-expiry.el --- expiry mechanism for Org entries 2 ;; 3 ;; Copyright 2007-2021 Free Software Foundation, Inc. 4 ;; 5 ;; Author: Bastien Guerry <bzg@gnu.org> 6 ;; Version: 0.2 7 ;; Keywords: org, expiry 8 ;; Homepage: https://git.sr.ht/~bzg/org-contrib 9 10 ;; This file is not part of GNU Emacs. 11 12 ;; This program is free software; you can redistribute it and/or modify 13 ;; it under the terms of the GNU General Public License as published by 14 ;; the Free Software Foundation; either version 3, or (at your option) 15 ;; any later version. 16 ;; 17 ;; This program is distributed in the hope that it will be useful, 18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 ;; GNU General Public License for more details. 21 ;; 22 ;; You should have received a copy of the GNU General Public License 23 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 24 ;; 25 ;;; Commentary: 26 ;; 27 ;; This gives you a chance to get rid of old entries in your Org files 28 ;; by expiring them. 29 ;; 30 ;; By default, entries that have no EXPIRY property are considered to be 31 ;; new (i.e. 0 day old) and only entries older than one year go to the 32 ;; expiry process, which consist in adding the ARCHIVE tag. None of 33 ;; your tasks will be deleted with the default settings. 34 ;; 35 ;; When does an entry expires? 36 ;; 37 ;; Consider this entry: 38 ;; 39 ;; * Stop watching TV 40 ;; :PROPERTIES: 41 ;; :CREATED: <2008-01-07 lun 08:01> 42 ;; :EXPIRY: <2008-01-09 08:01> 43 ;; :END: 44 ;; 45 ;; This entry will expire on the 9th, january 2008. 46 47 ;; * Stop watching TV 48 ;; :PROPERTIES: 49 ;; :CREATED: <2008-01-07 lun 08:01> 50 ;; :EXPIRY: +1w 51 ;; :END: 52 ;; 53 ;; This entry will expire on the 14th, january 2008, one week after its 54 ;; creation date. 55 ;; 56 ;; What happen when an entry is expired? Nothing until you explicitly 57 ;; M-x org-expiry-process-entries When doing this, org-expiry will check 58 ;; for expired entries and request permission to process them. 59 ;; 60 ;; Processing an expired entries means calling the function associated 61 ;; with `org-expiry-handler-function'; the default is to add the tag 62 ;; :ARCHIVE:, but you can also add a EXPIRED keyword or even archive 63 ;; the subtree. 64 ;; 65 ;; Is this useful? Well, when you're in a brainstorming session, it 66 ;; might be useful to know about the creation date of an entry, and be 67 ;; able to archive those entries that are more than xxx days/weeks old. 68 ;; 69 ;; When you're in such a session, you can insinuate org-expiry like 70 ;; this: M-x org-expiry-insinuate 71 ;; 72 ;; Then, each time you're pressing M-RET to insert an item, the CREATION 73 ;; property will be automatically added. Same when you're scheduling or 74 ;; deadlining items. You can deinsinuate: M-x org-expiry-deinsinuate 75 76 ;;; Code: 77 78 ;;; User variables: 79 80 (defgroup org-expiry nil 81 "Org expiry process." 82 :tag "Org Expiry" 83 :group 'org) 84 85 (defcustom org-expiry-inactive-timestamps nil 86 "Insert inactive timestamps for created/expired properties." 87 :type 'boolean 88 :group 'org-expiry) 89 90 (defcustom org-expiry-created-property-name "CREATED" 91 "The name of the property for setting the creation date." 92 :type 'string 93 :group 'org-expiry) 94 95 (defcustom org-expiry-expiry-property-name "EXPIRY" 96 "The name of the property for setting the expiry date/delay." 97 :type 'string 98 :group 'org-expiry) 99 100 (defcustom org-expiry-keyword "EXPIRED" 101 "The default keyword for `org-expiry-add-keyword'." 102 :type 'string 103 :group 'org-expiry) 104 105 (defcustom org-expiry-wait "+1y" 106 "Time span between the creation date and the expiry. 107 The default value for this variable (\"+1y\") means that entries 108 will expire if there are at least one year old. 109 110 If the expiry delay cannot be retrieved from the entry or the 111 subtree above, the expiry process compares the expiry delay with 112 `org-expiry-wait'. This can be either an ISO date or a relative 113 time specification. See `org-read-date' for details." 114 :type 'string 115 :group 'org-expiry) 116 117 (defcustom org-expiry-created-date "+0d" 118 "The default creation date. 119 The default value of this variable (\"+0d\") means that entries 120 without a creation date will be handled as if they were created 121 today. 122 123 If the creation date cannot be retrieved from the entry or the 124 subtree above, the expiry process will compare the expiry delay 125 with this date. This can be either an ISO date or a relative 126 time specification. See `org-read-date' for details on relative 127 time specifications." 128 :type 'string 129 :group 'org-expiry) 130 131 (defcustom org-expiry-handler-function 'org-toggle-archive-tag 132 "Function to process expired entries. 133 Possible candidates for this function are: 134 135 `org-toggle-archive-tag' 136 `org-expiry-add-keyword' 137 `org-expiry-archive-subtree'" 138 :type 'function 139 :group 'org-expiry) 140 141 (defcustom org-expiry-confirm-flag t 142 "Non-nil means confirm expiration process." 143 :type '(choice 144 (const :tag "Always require confirmation" t) 145 (const :tag "Do not require confirmation" nil) 146 (const :tag "Require confirmation in interactive expiry process" 147 interactive)) 148 :group 'org-expiry) 149 150 (defcustom org-expiry-advised-functions 151 '(org-scheduled org-deadline org-time-stamp) 152 "A list of advised functions. 153 `org-expiry-insinuate' will activate the expiry advice for these 154 functions. `org-expiry-deinsinuate' will deactivate them." 155 :type 'boolean 156 :group 'list) 157 158 ;;; Advices and insinuation: 159 160 (defadvice org-schedule (after org-schedule-update-created) 161 "Update the creation-date property when calling `org-schedule'." 162 (org-expiry-insert-created)) 163 164 (defadvice org-deadline (after org-deadline-update-created) 165 "Update the creation-date property when calling `org-deadline'." 166 (org-expiry-insert-created)) 167 168 (defadvice org-time-stamp (after org-time-stamp-update-created) 169 "Update the creation-date property when calling `org-time-stamp'." 170 (org-expiry-insert-created)) 171 172 (defun org-expiry-insinuate (&optional arg) 173 "Add hooks and activate advices for org-expiry. 174 If ARG, also add a hook to `before-save-hook' in `org-mode' and 175 restart `org-mode' if necessary." 176 (interactive "P") 177 (ad-activate 'org-schedule) 178 (ad-activate 'org-time-stamp) 179 (ad-activate 'org-deadline) 180 (add-hook 'org-insert-heading-hook 'org-expiry-insert-created) 181 (add-hook 'org-after-todo-state-change-hook 'org-expiry-insert-created) 182 (add-hook 'org-after-tags-change-hook 'org-expiry-insert-created) 183 (when arg 184 (add-hook 'org-mode-hook 185 (lambda() (add-hook 'before-save-hook 186 'org-expiry-process-entries t t))) 187 ;; need this to refresh org-mode hooks 188 (when (eq major-mode 'org-mode) 189 (org-mode) 190 (if (called-interactively-p 'any) 191 (message "Org-expiry insinuated, `org-mode' restarted."))))) 192 193 (defun org-expiry-deinsinuate (&optional arg) 194 "Remove hooks and deactivate advices for org-expiry. 195 If ARG, also remove org-expiry hook in Org's `before-save-hook' 196 and restart `org-mode' if necessary." 197 (interactive "P") 198 (ad-deactivate 'org-schedule) 199 (ad-deactivate 'org-time-stamp) 200 (ad-deactivate 'org-deadline) 201 (remove-hook 'org-insert-heading-hook 'org-expiry-insert-created) 202 (remove-hook 'org-after-todo-state-change-hook 'org-expiry-insert-created) 203 (remove-hook 'org-after-tags-change-hook 'org-expiry-insert-created) 204 (remove-hook 'org-mode-hook 205 (lambda() (add-hook 'before-save-hook 206 'org-expiry-process-entries t t))) 207 (when arg 208 ;; need this to refresh org-mode hooks 209 (when (eq major-mode 'org-mode) 210 (org-mode) 211 (if (called-interactively-p 'any) 212 (message "Org-expiry de-insinuated, `org-mode' restarted."))))) 213 214 ;;; org-expiry-expired-p: 215 216 (defun org-expiry-expired-p () 217 "Check if the entry at point is expired. 218 Return nil if the entry is not expired. Otherwise return the 219 amount of time between today and the expiry date. 220 221 If there is no creation date, use `org-expiry-created-date'. 222 If there is no expiry date, use `org-expiry-wait'." 223 (let* ((ex-prop org-expiry-expiry-property-name) 224 (cr-prop org-expiry-created-property-name) 225 (ct (current-time)) 226 (cr (org-read-date nil t (or (org-entry-get (point) cr-prop t) 227 org-expiry-created-date))) 228 (ex-field (or (org-entry-get (point) ex-prop t) org-expiry-wait)) 229 (ex (if (string-match "^[ \t]?[+-]" ex-field) 230 (time-add cr (time-subtract (org-read-date nil t ex-field) ct)) 231 (org-read-date nil t ex-field)))) 232 (if (time-less-p ex ct) 233 (time-subtract ct ex)))) 234 235 ;;; Expire an entry or a region/buffer: 236 237 (defun org-expiry-process-entry (&optional force) 238 "Call `org-expiry-handler-function' on entry. 239 If FORCE is non-nil, don't require confirmation from the user. 240 Otherwise rely on `org-expiry-confirm-flag' to decide." 241 (interactive "P") 242 (save-excursion 243 (when (called-interactively-p) (org-reveal)) 244 (when (org-expiry-expired-p) 245 (org-back-to-heading) 246 (looking-at org-complex-heading-regexp) 247 (let* ((ov (make-overlay (point) (match-end 0))) 248 (e (org-expiry-expired-p)) 249 (d (time-to-number-of-days e))) 250 (overlay-put ov 'face 'secondary-selection) 251 (if (or force 252 (null org-expiry-confirm-flag) 253 (and (eq org-expiry-confirm-flag 'interactive) 254 (not (interactive))) 255 (and org-expiry-confirm-flag 256 (y-or-n-p (format "Entry expired by %d days. Process? " d)))) 257 (funcall org-expiry-handler-function)) 258 (delete-overlay ov))))) 259 260 (defun org-expiry-process-entries (beg end) 261 "Process all expired entries between BEG and END. 262 The expiry process will run the function defined by 263 `org-expiry-handler-functions'." 264 (interactive "r") 265 (save-excursion 266 (let ((beg (if (org-region-active-p) 267 (region-beginning) (point-min))) 268 (end (if (org-region-active-p) 269 (region-end) (point-max)))) 270 (goto-char beg) 271 (let ((expired 0) (processed 0)) 272 (while (and (outline-next-heading) (< (point) end)) 273 (when (org-expiry-expired-p) 274 (setq expired (1+ expired)) 275 (if (if (called-interactively-p 'any) 276 (call-interactively 'org-expiry-process-entry) 277 (org-expiry-process-entry)) 278 (setq processed (1+ processed))))) 279 (if (equal expired 0) 280 (message "No expired entry") 281 (message "Processed %d on %d expired entries" 282 processed expired)))))) 283 284 ;;; Insert created/expiry property: 285 (defun org-expiry-format-timestamp (timestr inactive) 286 "Properly format TIMESTR into an org (in)active timestamp" 287 (format (if inactive "[%s]" "<%s>") timestr)) 288 289 (defun org-expiry-insert-created (&optional arg) 290 "Insert or update a property with the creation date. 291 If ARG, always update it. With one `C-u' prefix, silently update 292 to today's date. With two `C-u' prefixes, prompt the user for to 293 update the date." 294 (interactive "P") 295 (let* ((d (org-entry-get (point) org-expiry-created-property-name)) 296 d-time d-hour timestr) 297 (when (or (null d) arg) 298 ;; update if no date or non-nil prefix argument 299 ;; FIXME Use `org-time-string-to-time' 300 (setq d-time (if d (org-time-string-to-time d) 301 (current-time))) 302 (setq d-hour (format-time-string "%H:%M" d-time)) 303 (setq timestr 304 ;; two C-u prefixes will call org-read-date 305 (concat "<" 306 (if (equal arg '(16)) 307 (org-read-date nil nil nil nil d-time d-hour) 308 (format-time-string 309 (replace-regexp-in-string "\\(^<\\|>$\\)" "" 310 (cdr org-time-stamp-formats)))) 311 ">")) 312 ;; maybe transform to inactive timestamp 313 (if org-expiry-inactive-timestamps 314 (setq timestr (concat "[" (substring timestr 1 -1) "]"))) 315 (save-excursion 316 (org-entry-put 317 (point) org-expiry-created-property-name timestr))))) 318 319 (defun org-expiry-insert-expiry (&optional today) 320 "Insert a property with the expiry date. 321 With one `C-u' prefix, don't prompt interactively for the date 322 and insert today's date." 323 (interactive "P") 324 (let* ((d (org-entry-get (point) org-expiry-expiry-property-name)) 325 d-time d-hour) 326 (setq d-time (if d (org-time-string-to-time d) 327 (current-time))) 328 (setq d-hour (format-time-string "%H:%M" d-time)) 329 (setq timestr (concat "<" 330 (if today 331 (format-time-string 332 (replace-regexp-in-string "\\(^<\\|>$\\)" "" 333 (cdr org-time-stamp-formats))) 334 (org-read-date nil nil nil nil d-time d-hour)) 335 ">")) 336 ;; maybe transform to inactive timestamp 337 (if org-expiry-inactive-timestamps 338 (setq timestr (concat "[" (substring timestr 1 -1) "]"))) 339 340 (save-excursion 341 (org-entry-put 342 (point) org-expiry-expiry-property-name timestr)))) 343 344 ;;; Functions to process expired entries: 345 346 (defun org-expiry-archive-subtree () 347 "Archive the entry at point if it is expired." 348 (interactive) 349 (save-excursion 350 (if (org-expiry-expired-p) 351 (org-archive-subtree) 352 (if (called-interactively-p 'any) 353 (message "Entry at point is not expired."))))) 354 355 (defun org-expiry-add-keyword (&optional keyword) 356 "Add KEYWORD to the entry at point if it is expired." 357 (interactive "sKeyword: ") 358 (if (or (member keyword org-todo-keywords-1) 359 (setq keyword org-expiry-keyword)) 360 (save-excursion 361 (if (org-expiry-expired-p) 362 (org-todo keyword) 363 (if (called-interactively-p 'any) 364 (message "Entry at point is not expired.")))) 365 (error "\"%s\" is not a to-do keyword in this buffer" keyword))) 366 367 ;; FIXME what about using org-refile ? 368 369 (provide 'org-expiry) 370 371 ;;; org-expiry.el ends here