config

Personal configuration.
git clone git://code.dwrz.net/config
Log | Files | Refs

org-datetree.el (11027B)


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