Commit | Line | Data |
---|---|---|
20908596 CD |
1 | ;;; org-bbdb.el --- Support for links to BBDB entries from within Org-mode |
2 | ||
ae940284 | 3 | ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. |
20908596 CD |
4 | |
5 | ;; Author: Carsten Dominik <carsten at orgmode dot org>, | |
6 | ;; Thomas Baumann <thomas dot baumann at ch dot tum dot de> | |
7 | ;; Keywords: outlines, hypermedia, calendar, wp | |
8 | ;; Homepage: http://orgmode.org | |
fdf730ed | 9 | ;; Version: 6.16 |
20908596 CD |
10 | ;; |
11 | ;; This file is part of GNU Emacs. | |
12 | ;; | |
b1fc2b50 | 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
20908596 | 14 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
15 | ;; the Free Software Foundation, either version 3 of the License, or |
16 | ;; (at your option) any later version. | |
20908596 CD |
17 | |
18 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 | ;; GNU General Public License for more details. | |
22 | ||
23 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
20908596 CD |
25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
26 | ;; | |
27 | ;;; Commentary: | |
28 | ||
29 | ;; This file implements links to BBDB database entries from within Org-mode. | |
30 | ;; Org-mode loads this module by default - if this is not what you want, | |
31 | ;; configure the variable `org-modules'. | |
32 | ||
20908596 CD |
33 | ;; It also implements an interface (based on Ivar Rummelhoff's |
34 | ;; bbdb-anniv.el) for those org-mode users, who do not use the diary | |
35 | ;; but who do want to include the anniversaries stored in the BBDB | |
36 | ;; into the org-agenda. If you already include the `diary' into the | |
37 | ;; agenda, you might want to prefer to include the anniversaries in | |
38 | ;; the diary using bbdb-anniv.el. | |
39 | ;; | |
40 | ;; Put the following in /somewhere/at/home/diary.org and make sure | |
41 | ;; that this file is in `org-agenda-files` | |
42 | ;; | |
43 | ;; %%(org-bbdb-anniversaries) | |
44 | ;; | |
45 | ;; For example my diary.org looks like: | |
46 | ;; * Anniversaries | |
47 | ;; #+CATEGORY: Anniv | |
48 | ;; %%(org-bbdb-anniversaries) | |
49 | ;; | |
50 | ;; | |
51 | ;; The anniversaries are stored in BBDB in the field `anniversary' | |
52 | ;; in the format | |
53 | ;; | |
54 | ;; YYYY-MM-DD{ CLASS-OR-FORMAT-STRING}* | |
55 | ;; {\nYYYY-MM-DD CLASS-OR-FORMAT-STRING}* | |
56 | ;; | |
57 | ;; CLASS-OR-FORMAT-STRING is one of two things: | |
58 | ;; | |
59 | ;; * an identifier for a class of anniversaries (eg. birthday or | |
60 | ;; wedding) from `org-bbdb-anniversary-format-alist'. | |
61 | ;; * the (format) string displayed in the diary. | |
62 | ;; | |
63 | ;; It defaults to the value of `org-bbdb-default-anniversary-format' | |
64 | ;; ("birthday" by default). | |
65 | ;; | |
66 | ;; The substitutions in the format string are (in order): | |
67 | ;; * the name of the record containing this anniversary | |
68 | ;; * the number of years | |
69 | ;; * an ordinal suffix (st, nd, rd, th) for the year | |
70 | ;; | |
71 | ;; See the documentation of `org-bbdb-anniversary-format-alist' for | |
72 | ;; further options. | |
73 | ;; | |
74 | ;; Example | |
75 | ;; | |
76 | ;; 1973-06-22 | |
77 | ;; 20??-??-?? wedding | |
78 | ;; 1998-03-12 %s created bbdb-anniv.el %d years ago | |
b349f79f CD |
79 | ;; |
80 | ;; From Org's agenda, you can use `C-c C-o' to jump to the BBDB | |
81 | ;; link from which the entry at point originates. | |
82 | ;; | |
20908596 CD |
83 | ;;; Code: |
84 | ||
85 | (require 'org) | |
86 | (eval-when-compile | |
87 | (require 'cl)) | |
88 | ||
89 | ;; Declare external functions and variables | |
90 | ||
91 | (declare-function bbdb "ext:bbdb-com" (string elidep)) | |
92 | (declare-function bbdb-company "ext:bbdb-com" (string elidep)) | |
93 | (declare-function bbdb-current-record "ext:bbdb-com" | |
94 | (&optional planning-on-modifying)) | |
95 | (declare-function bbdb-name "ext:bbdb-com" (string elidep)) | |
96 | (declare-function bbdb-record-getprop "ext:bbdb" (record property)) | |
97 | (declare-function bbdb-record-name "ext:bbdb" (record)) | |
98 | (declare-function bbdb-records "ext:bbdb" | |
99 | (&optional dont-check-disk already-in-db-buffer)) | |
100 | (declare-function bbdb-split "ext:bbdb" (string separators)) | |
101 | (declare-function bbdb-string-trim "ext:bbdb" (string)) | |
102 | (declare-function calendar-leap-year-p "calendar" (year)) | |
103 | (declare-function diary-ordinal-suffix "diary-lib" (n)) | |
104 | ||
b349f79f | 105 | (defvar date) ;; dynamically scoped from Org |
20908596 CD |
106 | |
107 | ;; Customization | |
108 | ||
109 | (defgroup org-bbdb-anniversaries nil | |
110 | "Customizations for including anniversaries from BBDB into Agenda." | |
111 | :group 'org-bbdb) | |
112 | ||
113 | (defcustom org-bbdb-default-anniversary-format "birthday" | |
114 | "Default anniversary class." | |
115 | :type 'string | |
116 | :group 'org-bbdb-anniversaries | |
117 | :require 'bbdb) | |
118 | ||
119 | (defcustom org-bbdb-anniversary-format-alist | |
b349f79f CD |
120 | '(("birthday" lambda |
121 | (name years suffix) | |
122 | (concat "Birthday: [[bbdb:" name "][" name " (" | |
123 | (number-to-string years) | |
124 | suffix ")]]")) | |
125 | ("wedding" lambda | |
126 | (name years suffix) | |
127 | (concat "[[bbdb:" name "][" name "'s " | |
128 | (number-to-string years) | |
129 | suffix " wedding anniversary]]"))) | |
20908596 CD |
130 | "How different types of anniversaries should be formatted. |
131 | An alist of elements (STRING . FORMAT) where STRING is the name of an | |
132 | anniversary class and format is either: | |
133 | 1) A format string with the following substitutions (in order): | |
134 | * the name of the record containing this anniversary | |
135 | * the number of years | |
136 | * an ordinal suffix (st, nd, rd, th) for the year | |
137 | ||
138 | 2) A function to be called with three arguments: NAME YEARS SUFFIX | |
139 | (string int string) returning a string for the diary or nil. | |
140 | ||
141 | 3) An Emacs Lisp form that should evaluate to a string (or nil) in the | |
142 | scope of variables NAME, YEARS and SUFFIX (among others)." | |
143 | :type 'sexp | |
144 | :group 'org-bbdb-anniversaries | |
145 | :require 'bbdb) | |
146 | ||
147 | (defcustom org-bbdb-anniversary-field 'anniversary | |
148 | "The BBDB field which contains anniversaries. | |
149 | The anniversaries are stored in the following format | |
150 | ||
151 | YYYY-MM-DD Class-or-Format-String | |
152 | ||
153 | where class is one of the customized classes for anniversaries; | |
154 | birthday and wedding are predefined. Format-String can take three | |
155 | substitutions 1) the name of the record containing this | |
156 | anniversary, 2) the number of years, and 3) an ordinal suffix for | |
157 | the year. | |
158 | ||
888b663c | 159 | Multiple anniversaries can be separated by \\n." |
20908596 CD |
160 | :type 'symbol |
161 | :group 'org-bbdb-anniversaries | |
162 | :require 'bbdb) | |
163 | ||
164 | (defcustom org-bbdb-extract-date-fun 'org-bbdb-anniv-extract-date | |
165 | "How to retrieve `month date year' from the anniversary field. | |
166 | ||
888b663c | 167 | Customize if you have already filled your BBDB with dates |
20908596 | 168 | different from YYYY-MM-DD. The function must return a list (month |
888b663c | 169 | date year)." |
20908596 CD |
170 | :type 'function |
171 | :group 'org-bbdb-anniversaries | |
172 | :require 'bbdb) | |
173 | ||
174 | ||
175 | ;; Install the link type | |
176 | (org-add-link-type "bbdb" 'org-bbdb-open 'org-bbdb-export) | |
177 | (add-hook 'org-store-link-functions 'org-bbdb-store-link) | |
178 | ||
179 | ;; Implementation | |
180 | (defun org-bbdb-store-link () | |
181 | "Store a link to a BBDB database entry." | |
182 | (when (eq major-mode 'bbdb-mode) | |
183 | ;; This is BBDB, we make this link! | |
184 | (let* ((name (bbdb-record-name (bbdb-current-record))) | |
185 | (company (bbdb-record-getprop (bbdb-current-record) 'company)) | |
186 | (link (org-make-link "bbdb:" name))) | |
187 | (org-store-link-props :type "bbdb" :name name :company company | |
188 | :link link :description name) | |
189 | link))) | |
190 | ||
191 | (defun org-bbdb-export (path desc format) | |
192 | "Create the export version of a BBDB link specified by PATH or DESC. | |
193 | If exporting to either HTML or LaTeX FORMAT the link will be | |
194 | italicised, in all other cases it is left unchanged." | |
20908596 CD |
195 | (cond |
196 | ((eq format 'html) (format "<i>%s</i>" (or desc path))) | |
197 | ((eq format 'latex) (format "\\textit{%s}" (or desc path))) | |
198 | (t (or desc path)))) | |
199 | ||
200 | (defun org-bbdb-open (name) | |
201 | "Follow a BBDB link to NAME." | |
202 | (require 'bbdb) | |
203 | (let ((inhibit-redisplay (not debug-on-error)) | |
204 | (bbdb-electric-p nil)) | |
205 | (catch 'exit | |
206 | ;; Exact match on name | |
207 | (bbdb-name (concat "\\`" name "\\'") nil) | |
208 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | |
209 | ;; Exact match on name | |
210 | (bbdb-company (concat "\\`" name "\\'") nil) | |
211 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | |
212 | ;; Partial match on name | |
213 | (bbdb-name name nil) | |
214 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | |
215 | ;; Partial match on company | |
216 | (bbdb-company name nil) | |
217 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | |
218 | ;; General match including network address and notes | |
219 | (bbdb name nil) | |
220 | (when (= 0 (buffer-size (get-buffer "*BBDB*"))) | |
221 | (delete-window (get-buffer-window "*BBDB*")) | |
222 | (error "No matching BBDB record"))))) | |
223 | ||
224 | (defun org-bbdb-anniv-extract-date (time-str) | |
225 | "Convert YYYY-MM-DD to (month date year). | |
226 | Argument TIME-STR is the value retrieved from BBDB." | |
227 | (multiple-value-bind (y m d) (bbdb-split time-str "-") | |
228 | (list (string-to-number m) | |
229 | (string-to-number d) | |
230 | (string-to-number y)))) | |
231 | ||
232 | (defun org-bbdb-anniv-split (str) | |
888b663c | 233 | "Split multiple entries in the BBDB anniversary field. |
20908596 CD |
234 | Argument STR is the anniversary field in BBDB." |
235 | (let ((pos (string-match "[ \t]" str))) | |
236 | (if pos (list (substring str 0 pos) | |
237 | (bbdb-string-trim (substring str pos))) | |
238 | (list str nil)))) | |
239 | ||
b349f79f CD |
240 | (defvar org-bbdb-anniv-hash nil |
241 | "A hash holding anniversaries extracted from BBDB. | |
242 | The hash table is created on first use.") | |
20908596 | 243 | |
b349f79f CD |
244 | (defvar org-bbdb-updated-p t |
245 | "This is non-nil if BBDB has been updated since we last built the hash.") | |
246 | ||
247 | (defun org-bbdb-make-anniv-hash () | |
248 | "Create a hash with anniversaries extracted from BBDB, for fast access. | |
249 | The anniversaries are assumed to be stored `org-bbdb-anniversary-field'." | |
250 | ||
251 | (let (split tmp annivs) | |
252 | (clrhash org-bbdb-anniv-hash) | |
20908596 CD |
253 | (dolist (rec (bbdb-records)) |
254 | (when (setq annivs (bbdb-record-getprop | |
255 | rec org-bbdb-anniversary-field)) | |
256 | (setq annivs (bbdb-split annivs "\n")) | |
257 | (while annivs | |
258 | (setq split (org-bbdb-anniv-split (pop annivs))) | |
259 | (multiple-value-bind (m d y) | |
260 | (funcall org-bbdb-extract-date-fun (car split)) | |
b349f79f | 261 | (setq tmp (gethash (list m d) org-bbdb-anniv-hash)) |
ff4be292 CD |
262 | (puthash (list m d) (cons (list y |
263 | (bbdb-record-name rec) | |
b349f79f CD |
264 | (cadr split)) |
265 | tmp) | |
266 | org-bbdb-anniv-hash)))))) | |
267 | (setq org-bbdb-updated-p nil)) | |
268 | ||
269 | (defun org-bbdb-updated (rec) | |
270 | "Record the fact that BBDB has been updated. | |
271 | This is used by Org to re-create the anniversary hash table." | |
272 | (setq org-bbdb-updated-p t)) | |
20908596 | 273 | |
b349f79f CD |
274 | (add-hook 'bbdb-after-change-hook 'org-bbdb-updated) |
275 | ||
276 | ;;;###autoload | |
277 | (defun org-bbdb-anniversaries() | |
278 | "Extract anniversaries from BBDB for display in the agenda." | |
621f83e4 | 279 | (require 'bbdb) |
b349f79f CD |
280 | (require 'diary-lib) |
281 | (unless (hash-table-p org-bbdb-anniv-hash) | |
282 | (setq org-bbdb-anniv-hash | |
283 | (make-hash-table :test 'equal :size 366))) | |
284 | ||
285 | (when (or org-bbdb-updated-p | |
286 | (= 0 (hash-table-count org-bbdb-anniv-hash))) | |
287 | (org-bbdb-make-anniv-hash)) | |
288 | ||
289 | (let* ((m (car date)) ; month | |
290 | (d (nth 1 date)) ; day | |
291 | (y (nth 2 date)) ; year | |
292 | (annivs (gethash (list m d) org-bbdb-anniv-hash)) | |
293 | (text ()) | |
621f83e4 | 294 | split class form rec recs) |
ff4be292 | 295 | |
b349f79f | 296 | ;; we don't want to miss people born on Feb. 29th |
621f83e4 CD |
297 | (when (and (= m 3) (= d 1) |
298 | (not (null (gethash (list 2 29) org-bbdb-anniv-hash))) | |
299 | (not (calendar-leap-year-p y))) | |
300 | (setq recs (gethash (list 2 29) org-bbdb-anniv-hash)) | |
301 | (while (setq rec (pop recs)) | |
302 | (push rec annivs))) | |
b349f79f CD |
303 | |
304 | (when annivs | |
305 | (while (setq rec (pop annivs)) | |
ff4be292 | 306 | (when rec |
b349f79f CD |
307 | (let* ((class (or (nth 2 rec) |
308 | org-bbdb-default-anniversary-format)) | |
309 | (form (or (cdr (assoc class | |
310 | org-bbdb-anniversary-format-alist)) | |
311 | class)) ; (as format string) | |
312 | (name (nth 1 rec)) | |
313 | (years (- y (car rec))) | |
314 | (suffix (diary-ordinal-suffix years)) | |
315 | (tmp (cond | |
316 | ((functionp form) | |
317 | (funcall form name years suffix)) | |
318 | ((listp form) (eval form)) | |
319 | (t (format form name years suffix))))) | |
320 | (org-add-props tmp nil 'org-bbdb-name name) | |
321 | (if text | |
322 | (setq text (append text (list tmp))) | |
323 | (setq text (list tmp))))) | |
324 | )) | |
20908596 CD |
325 | (when text |
326 | (mapconcat 'identity text "; ")))) | |
327 | ||
328 | (provide 'org-bbdb) | |
329 | ||
88ac7b50 | 330 | ;; arch-tag: 9e4f275d-d080-48c1-b040-62247f66b5c2 |
b349f79f | 331 | |
20908596 | 332 | ;;; org-bbdb.el ends here |