1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
;;; bbdb-anniv.el --- Get anniversaries from BBDB
;; Copyright (C) 1998 Ivar Rummelhoff
;; Author: Ivar Rummelhoff <ivarru@math.uio.no>
;; Maintainer: Ivar Rummelhoff <ivarru@math.uio.no>
;; Created: 11 March 1998
;; Time-stamp: <00/08/07 10:52:12 ivarru>
;; Keywords: calendar
;; This program 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 2, or (at your option)
;; any later version.
;;
;; This program 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.
;;
;; If you have not received a copy of the GNU General Public License
;; along with this software, it can be obtained from the GNU Project's
;; World Wide Web server (http://www.gnu.org/copyleft/gpl.html), from
;; its FTP server (ftp://ftp.gnu.org/pub/gnu/GPL), by sending an electronic
;; mail to this program's maintainer or by writing to the Free Software
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;; Commentary:
;; (require 'bbdb-anniv)
;; (add-hook 'list-diary-entries-hook #'bbdb-include-anniversaries)
;;
;; will include BBDB-anniversaries when the diary is displayed
;; (fancy). The anniversaries are stored in the field `anniversary'
;; in the format
;;
;; [YYYY-MM-DD CLASS-OR-FORMAT-STRING]
;; {\nYYYY-MM-DD CLASS-OR-FORMAT-STRING}*
;;
;; CLASS-OR-FORMAT-STRING is one of two things:
;;
;; * an identifier for a class of anniversaries (eg. birthday or
;; wedding) from `bbdb-anniversary-format-alist'.
;; * the (format) string displayed in the diary.
;;
;; It defaults to the value of `bbdb-default-anniversary-format'
;; ("birthday" by default).
;;
;; The substitutions in the format string are (in order):
;; * the name of the record containing this anniversary
;; * the number of years
;; * an ordinal suffix (st, nd, rd, th) for the year
;;
;; See the documentation of `bbdb-anniversary-format-alist' for
;; further options.
;;
;; Example (my own record):
;;
;; 1973-06-22
;; 20??-??-?? wedding
;; 1998-03-12 %s created bbdb-anniv.el %d years ago
;;
;; If you use the hook `sort-diary-entries', you should make sure that
;; it is executed after `bbdb-include-anniversaries'.
;;
(require 'bbdb)
(require 'diary-lib)
(eval-when-compile (require 'cl))
;;;###autoload
(defgroup bbdb-utilities-anniversaries nil
"Customizations for including diary anniversaries from BBDB."
:link '(emacs-library-link :tag "Lisp File" "bbdb-anniv.el")
:group 'bbdb-utilities)
;;;###autoload
(defcustom bbdb-anniversaries nil
"Should BBDB anniversaries be included when the diary is displayed (fancy)?
You must modify via \\[customize] for this variable to have an effect."
:set #'(lambda (symbol value)
(if value
(add-hook 'list-diary-entries-hook
#'bbdb-include-anniversaries)
(remove-hook 'list-diary-entries-hook
#'bbdb-include-anniversaries)))
:type 'boolean
:group 'bbdb-utilities-anniversaries
:require 'bbdb-anniv)
(defcustom bbdb-default-anniversary-format "birthday"
"Default anniversary class"
:type 'string
:group 'bbdb-utilities-anniversaries
:require 'bbdb)
(defcustom bbdb-anniversary-format-alist
'( ("birthday" . "Birthday: %s (%d%s)")
("wedding" . "%s's %d%s wedding anniversary") )
"How different types of anniversaries should be formatted.
An alist of elements (STRING . FORMAT) where STRING is the name of an
anniversary class and format is either:
1) A format string with the following substitutions (in order):
* the name of the record containing this anniversary
* the number of years
* an ordinal suffix (st, nd, rd, th) for the year
2) A function to be called with three arguments: NAME YEARS SUFFIX
(string int string) returning a string for the diary or nil.
3) An emacs lisp form that should evaluate to a string (or nil) in the
scope of variables NAME, YEARS and SUFFIX (among others)."
:type 'sexp
:group 'bbdb-utilities-anniversaries
:require 'bbdb)
(defcustom bbdb-anniversary-field 'anniversary
"Which BBDB field contains anniversaries."
:type 'symbol
:group 'bbdb-utilities-anniversaries
:require 'bbdb)
(defcustom bbdb-extract-date-fun 'bbdb-anniv-extract-date
"How to retrieve `month date year' from the anniversary field."
:type 'function
:group 'bbdb-utilities-anniversaries
:require 'bbdb)
(defcustom bbdb-anniversary-reminder-days 0
"Number of days warning you are given of an impending anniversary.
Modify this to give yourself a n-day warning of those important
anniversaries. This works in a naive fashion, extending (forwards) the
range of days for which diary entries are being listed. When set to 0,
the behaviour is to only list anniversaries on the day."
:type 'integer
:group 'bbdb-utilities-anniversaries
:require 'bbdb)
;; YYYY-MM-DD => (month date year)
(defun bbdb-anniv-extract-date (time-str)
(multiple-value-bind (y m d) (bbdb-split time-str "-")
(list (string-to-number m)
(string-to-number d)
(string-to-number y))))
(defun bbdb-anniv-split (str)
(let ((pos (string-match "[ \t]" str)))
(if pos (list (substring str 0 pos)
(bbdb-string-trim (substring str pos)))
(list str nil))))
(defvar number)
(defvar original-date)
;;;###autoload
(defun bbdb-include-anniversaries ()
(let ((dates (loop repeat (+ number bbdb-anniversary-reminder-days)
for num from (calendar-absolute-from-gregorian
original-date)
for date = original-date
then (calendar-gregorian-from-absolute num)
;; ((MM . DD) . YYYY)
collect (cons (cons (extract-calendar-month date)
(extract-calendar-day date))
(extract-calendar-year date))))
annivs date years
split class form)
(dolist (rec (bbdb-records))
(when (setq annivs (bbdb-record-getprop
rec bbdb-anniversary-field))
(setq annivs (bbdb-split annivs "\n"))
(while annivs
(setq split (bbdb-anniv-split (pop annivs)))
(multiple-value-bind (m d y)
(funcall bbdb-extract-date-fun (car split))
(when (and (or (setq date (assoc (cons m d) dates))
(and (= d 29)
(= m 2)
(setq date (assoc '(3 . 1) dates))
(not (calendar-leap-year-p (cdr date)))))
(< 0 (setq years (- (cdr date) y))))
(let* ((class (or (cadr split)
bbdb-default-anniversary-format))
(form (or (cdr (assoc class
bbdb-anniversary-format-alist))
class)) ; (as format string)
(name (bbdb-record-name rec))
(suffix (diary-ordinal-suffix years))
(text (cond
((functionp form)
(funcall form name years suffix))
((listp form) (eval form))
(t (format form name years suffix)))))
(when text
(bbdb-anniv-add
(list (caar date) (cdar date) (cdr date)) ; MM DD YYYY
text))))))))))
(defun bbdb-anniv-add (a b)
(add-to-diary-list a b ""))
(provide 'bbdb-anniv)
;;; bbdb-anniv.el ends here
|
