| 1 | ;;; org-bbdb.el --- Support for links to BBDB entries from within Org-mode |
| 2 | |
| 3 | ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. |
| 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 |
| 9 | ;; Version: 6.16 |
| 10 | ;; |
| 11 | ;; This file is part of GNU Emacs. |
| 12 | ;; |
| 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 14 | ;; it under the terms of the GNU General Public License as published by |
| 15 | ;; the Free Software Foundation, either version 3 of the License, or |
| 16 | ;; (at your option) any later version. |
| 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 |
| 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 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 | |
| 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 |
| 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 | ;; |
| 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 | |
| 105 | (defvar date) ;; dynamically scoped from Org |
| 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 |
| 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]]"))) |
| 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 | |
| 159 | Multiple anniversaries can be separated by \\n." |
| 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 | |
| 167 | Customize if you have already filled your BBDB with dates |
| 168 | different from YYYY-MM-DD. The function must return a list (month |
| 169 | date year)." |
| 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." |
| 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) |
| 233 | "Split multiple entries in the BBDB anniversary field. |
| 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 | |
| 240 | (defvar org-bbdb-anniv-hash nil |
| 241 | "A hash holding anniversaries extracted from BBDB. |
| 242 | The hash table is created on first use.") |
| 243 | |
| 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) |
| 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)) |
| 261 | (setq tmp (gethash (list m d) org-bbdb-anniv-hash)) |
| 262 | (puthash (list m d) (cons (list y |
| 263 | (bbdb-record-name rec) |
| 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)) |
| 273 | |
| 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." |
| 279 | (require 'bbdb) |
| 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 ()) |
| 294 | split class form rec recs) |
| 295 | |
| 296 | ;; we don't want to miss people born on Feb. 29th |
| 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))) |
| 303 | |
| 304 | (when annivs |
| 305 | (while (setq rec (pop annivs)) |
| 306 | (when rec |
| 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 | )) |
| 325 | (when text |
| 326 | (mapconcat 'identity text "; ")))) |
| 327 | |
| 328 | (provide 'org-bbdb) |
| 329 | |
| 330 | ;; arch-tag: 9e4f275d-d080-48c1-b040-62247f66b5c2 |
| 331 | |
| 332 | ;;; org-bbdb.el ends here |