[~bandali/configs] / lisp / bbdb / bbdb-anniv.el

;;; bbdb-anniv.el --- get anniversaries from BBDB -*- lexical-binding: t -*-

;; Copyright (C) 2011-2017  Free Software Foundation, Inc.

;; This file is part of the Insidious Big Brother Database (aka BBDB),

;; BBDB is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; BBDB is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with BBDB.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;; Anniversaries are stored in xfields as defined via `bbdb-anniv-alist'.
;; Each such field may contain multiple anniversaries entries with separators
;; defined via `bbdb-separator-alist' (newlines by default).
;; Each anniversary entry is a string DATE followed by optional TEXT.
;; DATE may take the same format as the date of ordinary diary entries.
;; In particular, `calendar-date-style' is obeyed via `diary-date-forms'.
;; If `bbdb-anniv-alist' has a non-nil FORM for this type of anniversary,
;; FORM is used to display the anniversary entry in the diary buffer.
;; If FORM is nil, TEXT is used instead to display the anniversary entry
;; in the diary buffer.
;;
;; To display BBDB anniversaries in the Emacs diary,
;; call `bbdb-initialize' with arg `anniv'.
;;
;; See the BBDB info manual for documentation.

;;; Code:

(require 'bbdb)
(require 'bbdb-com)
(require 'diary-lib)
(eval-when-compile
  (require 'cl-lib))

(defcustom bbdb-anniv-alist
  '((birthday . "%n's %d%s birthday")
    (wedding  . "%n's %d%s wedding anniversary")
    (anniversary))
  "Alist of rules for formatting anniversaries in the diary buffer.
Each element is of the form (LABEL . FORM).
LABEL is the xfield where this type of anniversaries is stored.
FORM is a format string with the following substitutions:
  %n  name of the record
  %d  number of years
  %s  ordinal suffix (st, nd, rd, th) for the year.
  %t  the optional text following the date string in field LABEL.
If FORM is nil, use the text following the date string in field LABEL
as format string."
  :type '(repeat (cons :tag "Rule"
                       (symbol :tag "Label")
                       (choice (string)
                               (const nil))))
  :group 'bbdb-utilities-anniv)

;; `bbdb-anniv-diary-entries' becomes a member of  `diary-list-entries-hook'.
;; When this hook is run by `diary-list-entries', the variable `original-date'
;; is bound to the value of arg DATE of `diary-list-entries'.
;; Also, `number' is arg NUMBER of `diary-list-entries'.
;; `diary-list-entries' selects the entries for NUMBER days starting with DATE.

(defvar original-date) ; defined in diary-lib
(with-no-warnings (defvar number)) ; defined in diary-lib

;;;###autoload
(defun bbdb-anniv-diary-entries ()
  "Add anniversaries from BBDB records to `diary-list-entries'.
This obeys `calendar-date-style' via `diary-date-forms'.
To enable this feature, put the following into your .emacs:

 \(add-hook 'diary-list-entries-hook 'bbdb-anniv-diary-entries)"
  ;; Loop over NUMBER dates starting from ORGINAL-DATE.
  (let* ((num-date (1- (calendar-absolute-from-gregorian original-date)))
         (end-date (+ num-date number)))
    (while (<= (setq num-date (1+ num-date)) end-date)
      (let* ((date (calendar-gregorian-from-absolute num-date))
             (dd (calendar-extract-day date))
             (mm (calendar-extract-month date))
             (yy (calendar-extract-year date))
             ;; We construct a regexp that only uses shy groups,
             ;; except for the part of the regexp matching the year.
             ;; This way we can grab the year from the date string.
             (year "\\([0-9]+\\)\\|\\*")
             (dayname (format "%s\\|%s\\.?" (calendar-day-name date)
                              (calendar-day-name date 'abbrev)))
             (lex-env `((day . ,(format "0*%d" dd))
                        (month . ,(format "0*%d" mm)) (year . ,year)
                        (dayname . ,dayname)
                        (monthname . ,(format "%s\\|%s" (calendar-month-name mm)
                                              (calendar-month-name mm 'abbrev)))))
             ;; Require that the matched date is at the beginning of the string.
             (fmt (format "\\`%s?\\(?:%%s\\)"
                          (regexp-quote diary-nonmarking-symbol)))
             date-forms)

        (cl-flet ((fun (date-form)
                       (push (cons (format fmt
                                           (mapconcat (lambda (form) (eval form lex-env))
                                                      (if (eq (car date-form) 'backup)
                                                          (cdr date-form) date-form)
                                                      "\\)\\(?:"))
                                   (eq (car date-form) 'backup))
                             date-forms)))
          (mapc #'fun diary-date-forms)

          ;; The anniversary of February 29 is considered to be March 1
          ;; in non-leap years.  So we search for February 29, too.
          (when (and (= mm 3) (= dd 1)
                     (not (calendar-leap-year-p yy)))
            (setq lex-env `((day . "0*29") (month . "0*2") (year . ,year)
                            (dayname . ,dayname)
                            (monthname . ,(format "%s\\|%s" (calendar-month-name 2)
                                                  (calendar-month-name 2 'abbrev)))))
            (mapc #'fun diary-date-forms)))

        (dolist (record (bbdb-records))
          (dolist (rule bbdb-anniv-alist)
            (dolist (anniv (bbdb-record-xfield-split record (car rule)))
              (let ((date-forms date-forms)
                    (anniv-string (concat anniv " X")) ; for backup forms
                    (case-fold-search t)
                    form yr text)
                (while (setq form (pop date-forms))
                  (when (string-match (car form) anniv-string)
                    (setq date-forms nil
                          yr (match-string 1 anniv-string)
                          yr (if (and yr (string-match-p "[0-9]+" yr))
                                 (- yy (string-to-number yr))
                               100) ; as in `diary-anniversary'
                          ;; For backup forms we should search backward in
                          ;; anniv-string from (match-end 0) for "\\<".
                          ;; That gets too complicated here!
                          ;; Yet for the default value of `diary-date-forms'
                          ;; this would matter only if anniv-string started
                          ;; with a time. That is rather rare for anniversaries.
                          ;; Then we may simply step backward by one character.
                          text (substring anniv-string (if (cdr form) ; backup
                                                           (1- (match-end 0))
                                                         (match-end 0))
                                          -1)
                          text (replace-regexp-in-string "\\`[ \t]+" "" text)
                          text (replace-regexp-in-string "[ \t]+\\'" "" text))
                    (if (cdr rule)
                        (setq text (replace-regexp-in-string "%t" text (cdr rule))))
                    ;; Add the anniversaries to `diary-entries-list'.
                    (if (and (numberp yr) (< 0 (length text)))
                        (diary-add-to-list
                         date
                         ;; `diary-add-to-list' expects an arg SPECIFIER for being
                         ;; able to jump to the location of the entry in the diary
                         ;; file.  Here we only have BBDB records.  So we use
                         ;; an empty string for SPECIFIER, but instead we `propertize'
                         ;; the STRING passed to `diary-add-to-list'.
                         (propertize
                          (format
                           ;; Text substitution similar to `diary-anniversary'.
                           (replace-regexp-in-string "%n" (bbdb-record-name record) text)
                           yr (diary-ordinal-suffix yr))
                          'diary-goto-entry (list 'bbdb-display-records (list record)))
                         ""))))))))))))

;; based on `diary-goto-entry'
(defun bbdb-anniv-goto-entry (button)
  "Jump to the diary entry for the BUTTON at point.
The character at point may have a text property `diary-goto-entry'
which should be a list (FUNCTION ARG1 ARG2 ...).  Then call FUNCTION
with args ARG1, ARG2, ... to locate the entry.  Otherwise follow
the rules used by `diary-goto-entry'."
  (let* ((fun-call (get-text-property (overlay-start button)
                                      'diary-goto-entry))
         (locator (button-get button 'locator))
         (marker (car locator))
         markbuf file)
    (cond (fun-call
           (apply (car fun-call) (cdr fun-call)))
          ;; If marker pointing to diary location is valid, use that.
          ((and marker (setq markbuf (marker-buffer marker)))
           (pop-to-buffer markbuf)
           (goto-char (marker-position marker)))
          ;; Marker is invalid (eg buffer has been killed).
          ((and (setq file (cadr locator))
                (file-exists-p file)
                (find-file-other-window file))
           (when (eq major-mode (default-value 'major-mode)) (diary-mode))
           (goto-char (point-min))
           (if (re-search-forward (format "%s.*\\(%s\\)"
                                          (regexp-quote (nth 2 locator))
                                          (regexp-quote (nth 3 locator)))
                                  nil t)
               (goto-char (match-beginning 1))))
          (t
           (message "Unable to locate this diary entry")))))

;; `diary-goto-entry-function' is rather inflexible if multiple packages
;; want to use it for its purposes: this variable can be hijacked
;; only once.  Here our function `bbdb-anniv-goto-entry' should work
;; for other packages, too.
(setq diary-goto-entry-function 'bbdb-anniv-goto-entry)

(provide 'bbdb-anniv)

;;; bbdb-anniv.el ends here
Commit	Line	Data
1a5de666 AB	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 . "029") (month . "02") (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