[emacs] update 4 drones
[~bandali/configs] / lisp / bbdb / bbdb-anniv.el
1 ;;; bbdb-anniv.el --- get anniversaries from BBDB -*- lexical-binding: t -*-
2
3 ;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
4
5 ;; This file is part of the Insidious Big Brother Database (aka BBDB),
6
7 ;; BBDB is free software: you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation, either version 3 of the License, or
10 ;; (at your option) any later version.
11
12 ;; BBDB is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
16
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
19
20 ;;; Commentary:
21 ;; Anniversaries are stored in xfields as defined via `bbdb-anniv-alist'.
22 ;; Each such field may contain multiple anniversaries entries with separators
23 ;; defined via `bbdb-separator-alist' (newlines by default).
24 ;; Each anniversary entry is a string DATE followed by optional TEXT.
25 ;; DATE may take the same format as the date of ordinary diary entries.
26 ;; In particular, `calendar-date-style' is obeyed via `diary-date-forms'.
27 ;; If `bbdb-anniv-alist' has a non-nil FORM for this type of anniversary,
28 ;; FORM is used to display the anniversary entry in the diary buffer.
29 ;; If FORM is nil, TEXT is used instead to display the anniversary entry
30 ;; in the diary buffer.
31 ;;
32 ;; To display BBDB anniversaries in the Emacs diary,
33 ;; call `bbdb-initialize' with arg `anniv'.
34 ;;
35 ;; See the BBDB info manual for documentation.
36
37 ;;; Code:
38
39 (require 'bbdb)
40 (require 'bbdb-com)
41 (require 'diary-lib)
42 (eval-when-compile
43 (require 'cl-lib))
44
45 (defcustom bbdb-anniv-alist
46 '((birthday . "%n's %d%s birthday")
47 (wedding . "%n's %d%s wedding anniversary")
48 (anniversary))
49 "Alist of rules for formatting anniversaries in the diary buffer.
50 Each element is of the form (LABEL . FORM).
51 LABEL is the xfield where this type of anniversaries is stored.
52 FORM is a format string with the following substitutions:
53 %n name of the record
54 %d number of years
55 %s ordinal suffix (st, nd, rd, th) for the year.
56 %t the optional text following the date string in field LABEL.
57 If FORM is nil, use the text following the date string in field LABEL
58 as format string."
59 :type '(repeat (cons :tag "Rule"
60 (symbol :tag "Label")
61 (choice (string)
62 (const nil))))
63 :group 'bbdb-utilities-anniv)
64
65 ;; `bbdb-anniv-diary-entries' becomes a member of `diary-list-entries-hook'.
66 ;; When this hook is run by `diary-list-entries', the variable `original-date'
67 ;; is bound to the value of arg DATE of `diary-list-entries'.
68 ;; Also, `number' is arg NUMBER of `diary-list-entries'.
69 ;; `diary-list-entries' selects the entries for NUMBER days starting with DATE.
70
71 (defvar original-date) ; defined in diary-lib
72 (with-no-warnings (defvar number)) ; defined in diary-lib
73
74 ;;;###autoload
75 (defun bbdb-anniv-diary-entries ()
76 "Add anniversaries from BBDB records to `diary-list-entries'.
77 This obeys `calendar-date-style' via `diary-date-forms'.
78 To enable this feature, put the following into your .emacs:
79
80 \(add-hook 'diary-list-entries-hook 'bbdb-anniv-diary-entries)"
81 ;; Loop over NUMBER dates starting from ORGINAL-DATE.
82 (let* ((num-date (1- (calendar-absolute-from-gregorian original-date)))
83 (end-date (+ num-date number)))
84 (while (<= (setq num-date (1+ num-date)) end-date)
85 (let* ((date (calendar-gregorian-from-absolute num-date))
86 (dd (calendar-extract-day date))
87 (mm (calendar-extract-month date))
88 (yy (calendar-extract-year date))
89 ;; We construct a regexp that only uses shy groups,
90 ;; except for the part of the regexp matching the year.
91 ;; This way we can grab the year from the date string.
92 (year "\\([0-9]+\\)\\|\\*")
93 (dayname (format "%s\\|%s\\.?" (calendar-day-name date)
94 (calendar-day-name date 'abbrev)))
95 (lex-env `((day . ,(format "0*%d" dd))
96 (month . ,(format "0*%d" mm)) (year . ,year)
97 (dayname . ,dayname)
98 (monthname . ,(format "%s\\|%s" (calendar-month-name mm)
99 (calendar-month-name mm 'abbrev)))))
100 ;; Require that the matched date is at the beginning of the string.
101 (fmt (format "\\`%s?\\(?:%%s\\)"
102 (regexp-quote diary-nonmarking-symbol)))
103 date-forms)
104
105 (cl-flet ((fun (date-form)
106 (push (cons (format fmt
107 (mapconcat (lambda (form) (eval form lex-env))
108 (if (eq (car date-form) 'backup)
109 (cdr date-form) date-form)
110 "\\)\\(?:"))
111 (eq (car date-form) 'backup))
112 date-forms)))
113 (mapc #'fun diary-date-forms)
114
115 ;; The anniversary of February 29 is considered to be March 1
116 ;; in non-leap years. So we search for February 29, too.
117 (when (and (= mm 3) (= dd 1)
118 (not (calendar-leap-year-p yy)))
119 (setq lex-env `((day . "0*29") (month . "0*2") (year . ,year)
120 (dayname . ,dayname)
121 (monthname . ,(format "%s\\|%s" (calendar-month-name 2)
122 (calendar-month-name 2 'abbrev)))))
123 (mapc #'fun diary-date-forms)))
124
125 (dolist (record (bbdb-records))
126 (dolist (rule bbdb-anniv-alist)
127 (dolist (anniv (bbdb-record-xfield-split record (car rule)))
128 (let ((date-forms date-forms)
129 (anniv-string (concat anniv " X")) ; for backup forms
130 (case-fold-search t)
131 form yr text)
132 (while (setq form (pop date-forms))
133 (when (string-match (car form) anniv-string)
134 (setq date-forms nil
135 yr (match-string 1 anniv-string)
136 yr (if (and yr (string-match-p "[0-9]+" yr))
137 (- yy (string-to-number yr))
138 100) ; as in `diary-anniversary'
139 ;; For backup forms we should search backward in
140 ;; anniv-string from (match-end 0) for "\\<".
141 ;; That gets too complicated here!
142 ;; Yet for the default value of `diary-date-forms'
143 ;; this would matter only if anniv-string started
144 ;; with a time. That is rather rare for anniversaries.
145 ;; Then we may simply step backward by one character.
146 text (substring anniv-string (if (cdr form) ; backup
147 (1- (match-end 0))
148 (match-end 0))
149 -1)
150 text (replace-regexp-in-string "\\`[ \t]+" "" text)
151 text (replace-regexp-in-string "[ \t]+\\'" "" text))
152 (if (cdr rule)
153 (setq text (replace-regexp-in-string "%t" text (cdr rule))))
154 ;; Add the anniversaries to `diary-entries-list'.
155 (if (and (numberp yr) (< 0 (length text)))
156 (diary-add-to-list
157 date
158 ;; `diary-add-to-list' expects an arg SPECIFIER for being
159 ;; able to jump to the location of the entry in the diary
160 ;; file. Here we only have BBDB records. So we use
161 ;; an empty string for SPECIFIER, but instead we `propertize'
162 ;; the STRING passed to `diary-add-to-list'.
163 (propertize
164 (format
165 ;; Text substitution similar to `diary-anniversary'.
166 (replace-regexp-in-string "%n" (bbdb-record-name record) text)
167 yr (diary-ordinal-suffix yr))
168 'diary-goto-entry (list 'bbdb-display-records (list record)))
169 ""))))))))))))
170
171 ;; based on `diary-goto-entry'
172 (defun bbdb-anniv-goto-entry (button)
173 "Jump to the diary entry for the BUTTON at point.
174 The character at point may have a text property `diary-goto-entry'
175 which should be a list (FUNCTION ARG1 ARG2 ...). Then call FUNCTION
176 with args ARG1, ARG2, ... to locate the entry. Otherwise follow
177 the rules used by `diary-goto-entry'."
178 (let* ((fun-call (get-text-property (overlay-start button)
179 'diary-goto-entry))
180 (locator (button-get button 'locator))
181 (marker (car locator))
182 markbuf file)
183 (cond (fun-call
184 (apply (car fun-call) (cdr fun-call)))
185 ;; If marker pointing to diary location is valid, use that.
186 ((and marker (setq markbuf (marker-buffer marker)))
187 (pop-to-buffer markbuf)
188 (goto-char (marker-position marker)))
189 ;; Marker is invalid (eg buffer has been killed).
190 ((and (setq file (cadr locator))
191 (file-exists-p file)
192 (find-file-other-window file))
193 (when (eq major-mode (default-value 'major-mode)) (diary-mode))
194 (goto-char (point-min))
195 (if (re-search-forward (format "%s.*\\(%s\\)"
196 (regexp-quote (nth 2 locator))
197 (regexp-quote (nth 3 locator)))
198 nil t)
199 (goto-char (match-beginning 1))))
200 (t
201 (message "Unable to locate this diary entry")))))
202
203 ;; `diary-goto-entry-function' is rather inflexible if multiple packages
204 ;; want to use it for its purposes: this variable can be hijacked
205 ;; only once. Here our function `bbdb-anniv-goto-entry' should work
206 ;; for other packages, too.
207 (setq diary-goto-entry-function 'bbdb-anniv-goto-entry)
208
209 (provide 'bbdb-anniv)
210
211 ;;; bbdb-anniv.el ends here