| commit | author | age | ||
| 76bbd0 | 1 | ;;; org-datetree.el --- Create date entries in a tree -*- lexical-binding: t; -*- |
| C | 2 | |
| 3 | ;; Copyright (C) 2009-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 code to create entries in a tree where the top-level | |
| 28 | ;; nodes represent years, the level 2 nodes represent the months, and the | |
| 29 | ;; level 1 entries days. | |
| 30 | ||
| 31 | ;;; Code: | |
| 32 | ||
| 33 | (require 'org) | |
| 34 | ||
| 35 | (defvar org-datetree-base-level 1 | |
| 36 | "The level at which years should be placed in the date tree. | |
| 37 | This is normally one, but if the buffer has an entry with a | |
| 38 | DATE_TREE (or WEEK_TREE for ISO week entries) property (any | |
| 39 | value), the date tree will become a subtree under that entry, so | |
| 40 | the base level will be properly adjusted.") | |
| 41 | ||
| 42 | (defcustom org-datetree-add-timestamp nil | |
| 43 | "When non-nil, add a time stamp matching date of entry. | |
| 44 | Added time stamp is active unless value is `inactive'." | |
| 45 | :group 'org-capture | |
| 46 | :version "24.3" | |
| 47 | :type '(choice | |
| 48 | (const :tag "Do not add a time stamp" nil) | |
| 49 | (const :tag "Add an inactive time stamp" inactive) | |
| 50 | (const :tag "Add an active time stamp" active))) | |
| 51 | ||
| 52 | ;;;###autoload | |
| 53 | (defun org-datetree-find-date-create (d &optional keep-restriction) | |
| 54 | "Find or create an entry for date D. | |
| 55 | If KEEP-RESTRICTION is non-nil, do not widen the buffer. | |
| 56 | When it is nil, the buffer will be widened to make sure an existing date | |
| 57 | tree can be found. If it is the symbol `subtree-at-point', then the tree | |
| 58 | will be built under the headline at point." | |
| 59 | (setq-local org-datetree-base-level 1) | |
| 60 | (save-restriction | |
| 61 | (if (eq keep-restriction 'subtree-at-point) | |
| 62 | (progn | |
| 63 | (unless (org-at-heading-p) (error "Not at heading")) | |
| 64 | (widen) | |
| 65 | (org-narrow-to-subtree) | |
| 66 | (setq-local org-datetree-base-level | |
| 67 | (org-get-valid-level (org-current-level) 1))) | |
| 68 | (unless keep-restriction (widen)) | |
| 69 | ;; Support the old way of tree placement, using a property | |
| 70 | (let ((prop (org-find-property "DATE_TREE"))) | |
| 71 | (when prop | |
| 72 | (goto-char prop) | |
| 73 | (setq-local org-datetree-base-level | |
| 74 | (org-get-valid-level (org-current-level) 1)) | |
| 75 | (org-narrow-to-subtree)))) | |
| 76 | (goto-char (point-min)) | |
| 77 | (let ((year (calendar-extract-year d)) | |
| 78 | (month (calendar-extract-month d)) | |
| 79 | (day (calendar-extract-day d))) | |
| 80 | (org-datetree--find-create | |
| 81 | "^\\*+[ \t]+\\([12][0-9]\\{3\\}\\)\\(\\s-*?\ | |
| 82 | \\([ \t]:[[:alnum:]:_@#%%]+:\\)?\\s-*$\\)" | |
| 83 | year) | |
| 84 | (org-datetree--find-create | |
| 85 | "^\\*+[ \t]+%d-\\([01][0-9]\\) \\w+$" | |
| 86 | year month) | |
| 87 | (org-datetree--find-create | |
| 88 | "^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$" | |
| 89 | year month day)))) | |
| 90 | ||
| 91 | ;;;###autoload | |
| 92 | (defun org-datetree-find-iso-week-create (d &optional keep-restriction) | |
| 93 | "Find or create an ISO week entry for date D. | |
| 94 | Compared to `org-datetree-find-date-create' this function creates | |
| 95 | entries ordered by week instead of months. | |
| 96 | When it is nil, the buffer will be widened to make sure an existing date | |
| 97 | tree can be found. If it is the symbol `subtree-at-point', then the tree | |
| 98 | will be built under the headline at point." | |
| 99 | (setq-local org-datetree-base-level 1) | |
| 100 | (save-restriction | |
| 101 | (if (eq keep-restriction 'subtree-at-point) | |
| 102 | (progn | |
| 103 | (unless (org-at-heading-p) (error "Not at heading")) | |
| 104 | (widen) | |
| 105 | (org-narrow-to-subtree) | |
| 106 | (setq-local org-datetree-base-level | |
| 107 | (org-get-valid-level (org-current-level) 1))) | |
| 108 | (unless keep-restriction (widen)) | |
| 109 | ;; Support the old way of tree placement, using a property | |
| 110 | (let ((prop (org-find-property "WEEK_TREE"))) | |
| 111 | (when prop | |
| 112 | (goto-char prop) | |
| 113 | (setq-local org-datetree-base-level | |
| 114 | (org-get-valid-level (org-current-level) 1)) | |
| 115 | (org-narrow-to-subtree)))) | |
| 116 | (goto-char (point-min)) | |
| 117 | (require 'cal-iso) | |
| 118 | (let* ((year (calendar-extract-year d)) | |
| 119 | (month (calendar-extract-month d)) | |
| 120 | (day (calendar-extract-day d)) | |
| 121 | (time (encode-time 0 0 0 day month year)) | |
| 122 | (iso-date (calendar-iso-from-absolute | |
| 123 | (calendar-absolute-from-gregorian d))) | |
| 124 | (weekyear (nth 2 iso-date)) | |
| 125 | (week (nth 0 iso-date))) | |
| 126 | ;; ISO 8601 week format is %G-W%V(-%u) | |
| 127 | (org-datetree--find-create | |
| 128 | "^\\*+[ \t]+\\([12][0-9]\\{3\\}\\)\\(\\s-*?\ | |
| 129 | \\([ \t]:[[:alnum:]:_@#%%]+:\\)?\\s-*$\\)" | |
| 130 | weekyear nil nil | |
| 131 | (format-time-string "%G" time)) | |
| 132 | (org-datetree--find-create | |
| 133 | "^\\*+[ \t]+%d-W\\([0-5][0-9]\\)$" | |
| 134 | weekyear week nil | |
| 135 | (format-time-string "%G-W%V" time)) | |
| 136 | ;; For the actual day we use the regular date instead of ISO week. | |
| 137 | (org-datetree--find-create | |
| 138 | "^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$" | |
| 139 | year month day)))) | |
| 140 | ||
| 141 | (defun org-datetree--find-create (regex year &optional month day insert) | |
| 142 | "Find the datetree matched by REGEX for YEAR, MONTH, or DAY. | |
| 143 | REGEX is passed to `format' with YEAR, MONTH, and DAY as | |
| 144 | arguments. Match group 1 is compared against the specified date | |
| 145 | component. If INSERT is non-nil and there is no match then it is | |
| 146 | inserted into the buffer." | |
| 147 | (when (or month day) | |
| 148 | (org-narrow-to-subtree)) | |
| 149 | (let ((re (format regex year month day)) | |
| 150 | match) | |
| 151 | (goto-char (point-min)) | |
| 152 | (while (and (setq match (re-search-forward re nil t)) | |
| 153 | (goto-char (match-beginning 1)) | |
| 154 | (< (string-to-number (match-string 1)) (or day month year)))) | |
| 155 | (cond | |
| 156 | ((not match) | |
| 157 | (goto-char (point-max)) | |
| 158 | (unless (bolp) (insert "\n")) | |
| 159 | (org-datetree-insert-line year month day insert)) | |
| 160 | ((= (string-to-number (match-string 1)) (or day month year)) | |
| 161 | (beginning-of-line)) | |
| 162 | (t | |
| 163 | (beginning-of-line) | |
| 164 | (org-datetree-insert-line year month day insert))))) | |
| 165 | ||
| 166 | (defun org-datetree-insert-line (year &optional month day text) | |
| 167 | (delete-region (save-excursion (skip-chars-backward " \t\n") (point)) (point)) | |
| 168 | (insert "\n" (make-string org-datetree-base-level ?*) " \n") | |
| 169 | (backward-char) | |
| 170 | (when month (org-do-demote)) | |
| 171 | (when day (org-do-demote)) | |
| 172 | (if text | |
| 173 | (insert text) | |
| 174 | (insert (format "%d" year)) | |
| 175 | (when month | |
| 176 | (insert | |
| 177 | (if day | |
| 178 | (format-time-string "-%m-%d %A" (encode-time 0 0 0 day month year)) | |
| 179 | (format-time-string "-%m %B" (encode-time 0 0 0 1 month year)))))) | |
| 180 | (when (and day org-datetree-add-timestamp) | |
| 181 | (save-excursion | |
| 182 | (insert "\n") | |
| 183 | (org-indent-line) | |
| 184 | (org-insert-time-stamp | |
| 185 | (encode-time 0 0 0 day month year) | |
| 186 | nil | |
| 187 | (eq org-datetree-add-timestamp 'inactive)))) | |
| 188 | (beginning-of-line)) | |
| 189 | ||
| 190 | (defun org-datetree-file-entry-under (txt d) | |
| 191 | "Insert a node TXT into the date tree under date D." | |
| 192 | (org-datetree-find-date-create d) | |
| 193 | (let ((level (org-get-valid-level (funcall outline-level) 1))) | |
| 194 | (org-end-of-subtree t t) | |
| 195 | (org-back-over-empty-lines) | |
| 196 | (org-paste-subtree level txt))) | |
| 197 | ||
| 198 | (defun org-datetree-cleanup () | |
| 199 | "Make sure all entries in the current tree are under the correct date. | |
| 200 | It may be useful to restrict the buffer to the applicable portion | |
| 201 | before running this command, even though the command tries to be smart." | |
| 202 | (interactive) | |
| 203 | (goto-char (point-min)) | |
| 204 | (let ((dre (concat "\\<" org-deadline-string "\\>[ \t]*\\'")) | |
| 205 | (sre (concat "\\<" org-scheduled-string "\\>[ \t]*\\'"))) | |
| 206 | (while (re-search-forward org-ts-regexp nil t) | |
| 207 | (catch 'next | |
| 208 | (let ((tmp (buffer-substring | |
| 209 | (max (line-beginning-position) | |
| 210 | (- (match-beginning 0) org-ds-keyword-length)) | |
| 211 | (match-beginning 0)))) | |
| 212 | (when (or (string-suffix-p "-" tmp) | |
| 213 | (string-match dre tmp) | |
| 214 | (string-match sre tmp)) | |
| 215 | (throw 'next nil)) | |
| 216 | (let* ((dct (decode-time (org-time-string-to-time (match-string 0)))) | |
| 217 | (date (list (nth 4 dct) (nth 3 dct) (nth 5 dct))) | |
| 218 | (year (nth 2 date)) | |
| 219 | (month (car date)) | |
| 220 | (day (nth 1 date)) | |
| 221 | (pos (point)) | |
| 222 | (hdl-pos (progn (org-back-to-heading t) (point)))) | |
| 223 | (unless (org-up-heading-safe) | |
| 224 | ;; No parent, we are not in a date tree. | |
| 225 | (goto-char pos) | |
| 226 | (throw 'next nil)) | |
| 227 | (unless (looking-at "\\*+[ \t]+[0-9]+-[0-1][0-9]-[0-3][0-9]") | |
| 228 | ;; Parent looks wrong, we are not in a date tree. | |
| 229 | (goto-char pos) | |
| 230 | (throw 'next nil)) | |
| 231 | (when (looking-at (format "\\*+[ \t]+%d-%02d-%02d" year month day)) | |
| 232 | ;; At correct date already, do nothing. | |
| 233 | (goto-char pos) | |
| 234 | (throw 'next nil)) | |
| 235 | ;; OK, we need to refile this entry. | |
| 236 | (goto-char hdl-pos) | |
| 237 | (org-cut-subtree) | |
| 238 | (save-excursion | |
| 239 | (save-restriction | |
| 240 | (org-datetree-file-entry-under (current-kill 0) date))))))))) | |
| 241 | ||
| 242 | (provide 'org-datetree) | |
| 243 | ||
| 244 | ;; Local variables: | |
| 245 | ;; generated-autoload-file: "org-loaddefs.el" | |
| 246 | ;; End: | |
| 247 | ||
| 248 | ;;; org-datetree.el ends here | |
