Replace org-mode-p with usual (eq major-mode 'org-mode) check
[org-mode.git] / contrib / lisp / org-contacts.el
1 ;;; org-contacts.el --- Contacts management
2
3 ;; Copyright (C) 2010-2011 Julien Danjou <julien@danjou.info>
4
5 ;; Author: Julien Danjou <julien@danjou.info>
6 ;; Keywords: outlines, hypermedia, calendar
7 ;;
8 ;; This file is NOT part of GNU Emacs.
9 ;;
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 ;;
24 ;;; Commentary:
25
26 ;; This file contains the code for managing your contacts into Org-mode.
27
28 ;; To enter new contacts, you can use `org-capture' and a template just like
29 ;; this:
30
31 ;;         ("c" "Contacts" entry (file "~/Org/contacts.org")
32 ;;          "* %(org-contacts-template-name)
33 ;; :PROPERTIES:
34 ;; :EMAIL: %(org-contacts-template-email)
35 ;; :END:")))
36 ;;
37 ;;; Code:
38
39 (eval-when-compile
40   (require 'cl))
41
42 (eval-and-compile
43   (require 'org))
44
45 (defgroup org-contacts nil
46   "Options concerning contacts management."
47   :group 'org)
48
49 (defcustom org-contacts-files nil
50   "List of Org files to use as contacts source.
51 If set to nil, all your Org files will be used."
52   :type '(repeat file)
53   :group 'org-contacts)
54
55 (defcustom org-contacts-email-property "EMAIL"
56   "Name of the property for contact email address."
57   :type 'string
58   :group 'org-contacts)
59
60 (defcustom org-contacts-address-property "ADDRESS"
61   "Name of the property for contact address."
62   :type 'string
63   :group 'org-contacts)
64
65 (defcustom org-contacts-birthday-property "BIRTHDAY"
66   "Name of the property for contact birthday date."
67   :type 'string
68   :group 'org-contacts)
69
70 (defcustom org-contacts-birthday-format "Birthday: %l (%Y)"
71   "Format of the anniversary agenda entry. The following replacements are available:
72
73   %h - Heading name
74   %l - Link to the heading
75   %y - Number of year
76   %Y - Number of year (ordinal)"
77   :type 'string
78   :group 'org-contacts)
79
80 (defcustom org-contacts-last-read-mail-property "LAST_READ_MAIL"
81   "Name of the property for contact last read email link storage."
82   :type 'string
83   :group 'org-contacts)
84
85 (defcustom org-contacts-icon-property "ICON"
86   "Name of the property for contact icon."
87   :type 'string
88   :group 'org-contacts)
89
90 (defcustom org-contacts-nickname-property "NICKNAME"
91   "Name of the property for IRC nickname match."
92   :type 'string
93   :group 'org-contacts)
94
95 (defcustom org-contacts-icon-size 32
96   "Size of the contacts icons."
97   :type 'string
98   :group 'org-contacts)
99
100 (defcustom org-contacts-icon-use-gravatar (fboundp 'gravatar-retrieve)
101   "Whether use Gravatar to fetch contact icons."
102   :type 'boolean
103   :group 'org-contacts)
104
105 (defcustom org-contacts-completion-ignore-case t
106   "Ignore case when completing contacts."
107   :type 'boolean
108   :group 'org-contacts)
109
110 (defcustom org-contacts-group-prefix "+"
111   "Group prefix."
112   :type 'string
113   :group 'org-contacts)
114
115 (defcustom org-contacts-matcher (concat org-contacts-email-property "<>\"\"")
116   "Matching rule for finding heading that are contacts.
117 This can be a tag name, or a property check."
118   :type 'string
119   :group 'org-contacts)
120
121 (defcustom org-contacts-email-link-description-format "%s (%d)"
122   "Format used to store links to email.
123 This overrides `org-email-link-description-format' if set."
124   :group 'org-contacts
125   :type 'string)
126
127 (defcustom org-contacts-vcard-file "contacts.vcf"
128   "Default file for vcard export."
129   :group 'org-contacts
130   :type 'file)
131
132 (defvar org-contacts-keymap
133   (let ((map (make-sparse-keymap)))
134     (define-key map "M" 'org-contacts-view-send-email)
135     (define-key map "i" 'org-contacts-view-switch-to-irc-buffer)
136     map)
137   "The keymap used in `org-contacts' result list.")
138
139 (defun org-contacts-files ()
140   "Return list of Org files to use for contact management."
141   (or org-contacts-files (org-agenda-files t 'ifmode)))
142
143 (defun org-contacts-filter (&optional name-match tags-match)
144   "Search for a contact maching NAME-MATCH and TAGS-MATCH.
145 If both match values are nil, return all contacts."
146   (let ((tags-matcher
147          (if tags-match
148              (cdr (org-make-tags-matcher tags-match))
149            t))
150         (name-matcher
151          (if name-match
152              '(org-string-match-p name-match (org-get-heading t))
153            t))
154         (contacts-matcher
155          (cdr (org-make-tags-matcher org-contacts-matcher)))
156         markers result)
157     (dolist (file (org-contacts-files))
158       (org-check-agenda-file file)
159       (with-current-buffer (org-get-agenda-file-buffer file)
160         (unless (eq major-mode 'org-mode)
161           (error "File %s is no in `org-mode'" file))
162         (org-scan-tags
163          '(add-to-list 'markers (set-marker (make-marker) (point)))
164          `(and ,contacts-matcher ,tags-matcher ,name-matcher))))
165     (dolist (marker markers result)
166       (org-with-point-at marker
167         (add-to-list 'result
168                      (list (org-get-heading t) marker (org-entry-properties marker 'all)))))))
169
170 (when (not (fboundp 'completion-table-case-fold))
171   ;; That function is new in Emacs 24...
172   (defun completion-table-case-fold (table &optional dont-fold)
173     (lambda (string pred action)
174       (let ((completion-ignore-case (not dont-fold)))
175         (complete-with-action action table string pred)))))
176
177 (defun org-contacts-complete-name (&optional start)
178   "Complete text at START with a user name and email."
179   (let* ((end (point))
180          (start (or start
181                     (save-excursion
182                       (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
183                       (goto-char (match-end 0))
184                       (point))))
185          (orig (buffer-substring start end))
186          (completion-ignore-case org-contacts-completion-ignore-case)
187          (group-completion-p (org-string-match-p (concat "^" org-contacts-group-prefix) orig))
188          (completion-list
189           (if group-completion-p
190               (mapcar (lambda (group) (propertize (concat org-contacts-group-prefix group) 'org-contacts-group group))
191                       (org-uniquify
192                        (loop for contact in (org-contacts-filter)
193                              with group-list
194                              nconc (org-split-string
195                                     (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
196             (loop for contact in (org-contacts-filter)
197                   ;; The contact name is always the car of the assoc-list
198                   ;; returned by `org-contacts-filter'.
199                   for contact-name = (car contact)
200                   ;; Build the list of the user email addresses.
201                   for email-list = (split-string (or
202                                                   (cdr (assoc-string org-contacts-email-property (caddr contact)))
203                                                   ""))
204                   ;; If the user has email addresses…
205                   if email-list
206                   ;; â€¦ append a list of USER <EMAIL>.
207                   nconc (loop for email in email-list
208                               collect (org-contacts-format-email contact-name email)))))
209          (completion-list (all-completions orig completion-list)))
210     ;; If we are completing a group, and that's the only group, just return
211     ;; the real result.
212     (when (and group-completion-p
213                (= (length completion-list) 1))
214       (setq completion-list
215             (list (concat (car completion-list) ";: "
216                           (mapconcat 'identity
217                                      (loop for contact in (org-contacts-filter
218                                                            nil
219                                                            (get-text-property 0 'org-contacts-group (car completion-list)))
220                                            ;; The contact name is always the car of the assoc-list
221                                            ;; returned by `org-contacts-filter'.
222                                            for contact-name = (car contact)
223                                            ;; Grab the first email of the contact
224                                            for email = (car (split-string (or
225                                                                            (cdr (assoc-string org-contacts-email-property (caddr contact)))
226                                                                            "")))
227                                            ;; If the user has an email address, append USER <EMAIL>.
228                                            if email collect (org-contacts-format-email contact-name email))
229                                      ", ")))))
230     (list start end (completion-table-case-fold completion-list (not org-contacts-completion-ignore-case)))))
231
232 (defun org-contacts-message-complete-function ()
233   "Function used in `completion-at-point-functions' in `message-mode'."
234   (let ((mail-abbrev-mode-regexp
235          "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
236         (when (mail-abbrev-in-expansion-header-p)
237           (org-contacts-complete-name))))
238
239 (defun org-contacts-gnus-get-name-email ()
240   "Get name and email address from Gnus message."
241   (if (gnus-alive-p)
242       (gnus-with-article-headers
243         (mail-extract-address-components
244          (or (mail-fetch-field "From") "")))))
245
246 (defun org-contacts-gnus-article-from-get-marker ()
247   "Return a marker for a contact based on From."
248   (let* ((address (org-contacts-gnus-get-name-email))
249          (name (car address))
250          (email (cadr address)))
251     (cadar (or (org-contacts-filter
252                 nil
253                 (concat org-contacts-email-property "={\\b" (regexp-quote email) "\\b}"))
254                (when name
255                  (org-contacts-filter
256                   (concat "^" name "$")))))))
257
258 (defun org-contacts-gnus-article-from-goto ()
259   "Go to contact in the From address of current Gnus message."
260   (interactive)
261   (let ((marker (org-contacts-gnus-article-from-get-marker)))
262     (when marker
263       (switch-to-buffer-other-window (marker-buffer marker))
264       (goto-char marker)
265       (when (eq major-mode 'org-mode)
266         (org-show-context 'agenda)
267         (save-excursion
268           (and (outline-next-heading)
269                ;; show the next heading
270                (org-flag-heading nil)))))))
271
272 (defun org-contacts-anniversaries (&optional field format)
273   "Compute FIELD anniversary for each contact, returning FORMAT.
274 Default FIELD value is \"BIRTHDAY\".
275
276 Format is a string matching the following format specification:
277
278   %h - Heading name
279   %l - Link to the heading
280   %y - Number of year
281   %Y - Number of year (ordinal)"
282   (let ((calendar-date-style 'american)
283         (entry ""))
284     (unless format (setq format org-contacts-birthday-format))
285     (loop for contact in (org-contacts-filter)
286           for anniv = (let ((anniv (cdr (assoc-string
287                                          (or field org-contacts-birthday-property)
288                                          (caddr contact)))))
289                         (when anniv
290                           (calendar-gregorian-from-absolute
291                            (org-time-string-to-absolute anniv))))
292           ;; Use `diary-anniversary' to compute anniversary.
293           if (and anniv (apply 'diary-anniversary anniv))
294           collect (format-spec format
295                                `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
296                                  (?h . ,(car contact))
297                                  (?y . ,(- (calendar-extract-year date)
298                                            (calendar-extract-year anniv)))
299                                  (?Y . ,(let ((years (- (calendar-extract-year date)
300                                                         (calendar-extract-year anniv))))
301                                           (format "%d%s" years (diary-ordinal-suffix years)))))))))
302
303 (defun org-completing-read-date (prompt collection
304                                         &optional predicate require-match initial-input
305                                         hist def inherit-input-method)
306   "Like `completing-read' but reads a date.
307 Only PROMPT and DEF are really used."
308   (org-read-date nil nil nil prompt nil def))
309
310 (add-to-list 'org-property-set-functions-alist
311              `(,org-contacts-birthday-property . org-completing-read-date))
312
313 (defun org-contacts-template-name (&optional return-value)
314   "Try to return the contact name for a template.
315 If not found return RETURN-VALUE or something that would ask the user."
316   (or (car (org-contacts-gnus-get-name-email))
317       return-value
318       "%^{Name}"))
319
320 (defun org-contacts-template-email (&optional return-value)
321   "Try to return the contact email for a template.
322 If not found return RETURN-VALUE or something that would ask the user."
323   (or (cadr (org-contacts-gnus-get-name-email))
324       return-value
325       (concat "%^{" org-contacts-email-property "}p")))
326
327 (defun org-contacts-gnus-store-last-mail ()
328   "Store a link between mails and contacts.
329
330 This function should be called from `gnus-article-prepare-hook'."
331   (let ((marker (org-contacts-gnus-article-from-get-marker)))
332     (when marker
333       (with-current-buffer (marker-buffer marker)
334         (save-excursion
335           (goto-char marker)
336           (let* ((org-email-link-description-format (or org-contacts-email-link-description-format
337                                                         org-email-link-description-format))
338                  (link (gnus-with-article-buffer (org-store-link nil))))
339             (org-set-property org-contacts-last-read-mail-property link)))))))
340
341 (defun org-contacts-icon-as-string ()
342   (let ((image (org-contacts-get-icon)))
343     (concat
344      (propertize "-" 'display
345                  (append
346                   (if image
347                       image
348                     `'(space :width (,org-contacts-icon-size)))
349                   '(:ascent center)))
350      " ")))
351
352 ;;;###autoload
353 (defun org-contacts (name)
354   "Create agenda view for contacts matching NAME."
355   (interactive (list (read-string "Name: ")))
356   (let ((org-agenda-files (org-contacts-files))
357         (org-agenda-skip-function
358          (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
359         (org-agenda-format (propertize
360                             "%(org-contacts-icon-as-string)% p% s%(org-contacts-irc-number-of-unread-messages)%+T"
361                             'keymap org-contacts-keymap))
362         (org-agenda-overriding-header
363          (or org-agenda-overriding-header
364              (concat "List of contacts matching `" name "':"))))
365     (setq org-agenda-skip-regexp name)
366     (org-tags-view nil org-contacts-matcher)
367     (with-current-buffer org-agenda-buffer-name
368       (setq org-agenda-redo-command
369             (list 'org-contacts name)))))
370
371 (defun org-contacts-completing-read (prompt
372                                      &optional predicate
373                                      initial-input hist def inherit-input-method)
374   "Call `completing-read' with contacts name as collection."
375   (org-completing-read
376    prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method))
377
378 (defun org-contacts-format-email (name email)
379   "Format a mail address."
380   (unless email
381     (error "`email' cannot be nul"))
382   (if name
383       (concat name " <" email ">")
384     email))
385
386 (defun org-contacts-check-mail-address (mail)
387   "Add MAIL address to contact at point if it does not have it."
388   (let ((mails (org-entry-get (point) org-contacts-email-property)))
389     (unless (member mail (split-string mails))
390       (when (yes-or-no-p
391              (format "Do you want to this address to %s?" (org-get-heading t)))
392         (org-set-property org-contacts-email-property (concat mails " " mail))))))
393
394 (defun org-contacts-gnus-check-mail-address ()
395   "Check that contact has the current address recorded.
396 This function should be called from `gnus-article-prepare-hook'."
397   (let ((marker (org-contacts-gnus-article-from-get-marker)))
398     (when marker
399       (org-with-point-at marker
400         (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))
401
402 (defun org-contacts-gnus-insinuate ()
403   "Add some hooks for Gnus user.
404 This adds `org-contacts-gnus-check-mail-address' and
405 `org-contacts-gnus-store-last-mail' to
406 `gnus-article-prepare-hook'. It also adds a binding on `;' in
407 `gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
408   (require 'gnus)
409   (require 'gnus-art)
410   (define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto)
411   (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address)
412   (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail))
413
414 (when (boundp 'completion-at-point-functions)
415   (add-hook 'message-mode-hook
416             (lambda ()
417               (add-to-list 'completion-at-point-functions
418                            'org-contacts-message-complete-function))))
419
420 (defun org-contacts-wl-get-from-header-content ()
421   "Retrieve the content of the `From' header of an email.
422 Works from wl-summary-mode and mime-view-mode - that is while viewing email.
423 Depends on Wanderlust been loaded."
424   (with-current-buffer (org-capture-get :original-buffer)
425     (cond
426      ((eq major-mode 'wl-summary-mode) (when wl-summary-buffer-elmo-folder
427                                          (elmo-message-field
428                                           wl-summary-buffer-elmo-folder
429                                           (wl-summary-message-number)
430                                           'from)))
431      ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
432                                       (prog1
433                                           (std11-fetch-field "From")
434                                         (widen))))))
435
436 (defun org-contacts-wl-get-name-email ()
437   "Get name and email address from wanderlust email.
438 See `org-contacts-wl-get-from-header-content' for limitations."
439   (let ((from (org-contacts-wl-get-from-header-content)))
440     (when from
441       (list (wl-address-header-extract-realname from)
442             (wl-address-header-extract-address from)))))
443
444 (defun org-contacts-template-wl-name (&optional return-value)
445   "Try to return the contact name for a template from wl.
446 If not found return RETURN-VALUE or something that would ask the user."
447   (or (car (org-contacts-wl-get-name-email))
448       return-value
449       "%^{Name}"))
450
451 (defun org-contacts-template-wl-email (&optional return-value)
452   "Try to return the contact email for a template from wl.
453 If not found return RETURN-VALUE or something that would ask the user."
454   (or (cadr (org-contacts-wl-get-name-email))
455       return-value
456       (concat "%^{" org-contacts-email-property "}p")))
457
458 (defun org-contacts-view-send-email (&optional ask)
459   "Send email to the contact at point.
460 If ASK is set, ask for the email address even if there's only one address."
461   (interactive "P")
462   (let ((marker (org-get-at-bol 'org-hd-marker)))
463     (org-with-point-at marker
464       (let ((emails (org-entry-get (point) org-contacts-email-property)))
465         (if emails
466             (let ((email-list (split-string emails)))
467               (if (and (= (length email-list) 1) (not ask))
468                   (compose-mail (org-contacts-format-email
469                                  (org-get-heading t) emails))
470                 (let ((email (completing-read "Send mail to which address: " email-list)))
471                   (org-contacts-check-mail-address email)
472                   (compose-mail (org-contacts-format-email (org-get-heading t) email)))))
473           (error (format "This contact has no mail address set (no %s property)."
474                          org-contacts-email-property)))))))
475
476 (defun org-contacts-get-icon (&optional pom)
477   "Get icon for contact at POM."
478   (setq pom (or pom (point)))
479   (catch 'icon
480     ;; Use `org-contacts-icon-property'
481     (let ((image-data (org-entry-get pom org-contacts-icon-property)))
482       (when image-data
483         (throw 'icon
484                (if (fboundp 'gnus-rescale-image)
485                    (gnus-rescale-image (create-image image-data)
486                                        (cons org-contacts-icon-size org-contacts-icon-size))
487                  (create-image image-data)))))
488     ;; Next, try Gravatar
489     (when org-contacts-icon-use-gravatar
490       (let* ((gravatar-size org-contacts-icon-size)
491              (email-list (org-entry-get pom org-contacts-email-property))
492              (gravatar
493               (when email-list
494                 (loop for email in (split-string email-list)
495                       for gravatar = (gravatar-retrieve-synchronously email)
496                       if (and gravatar
497                               (not (eq gravatar 'error)))
498                       return gravatar))))
499         (when gravatar (throw 'icon gravatar))))))
500
501 (defun org-contacts-irc-buffer (&optional pom)
502   "Get the IRC buffer associated with the entry at POM."
503   (setq pom (or pom (point)))
504   (let ((nick (org-entry-get pom org-contacts-nickname-property)))
505     (when nick
506       (let ((buffer (get-buffer nick)))
507         (when buffer
508           (with-current-buffer buffer
509             (when (eq major-mode 'erc-mode)
510               buffer)))))))
511
512 (defun org-contacts-irc-number-of-unread-messages (&optional pom)
513   "Return the number of unread messages for contact at POM."
514   (when (boundp 'erc-modified-channels-alist)
515     (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist))))
516       (if number
517           (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number)
518         (make-string 21 ? )))))
519
520 (defun org-contacts-view-switch-to-irc-buffer ()
521   "Switch to the IRC buffer of the current contact if it has one."
522   (interactive)
523   (let ((marker (org-get-at-bol 'org-hd-marker)))
524     (org-with-point-at marker
525       (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
526
527 (defun org-contacts-completing-read-nickname (prompt collection
528                                                      &optional predicate require-match initial-input
529                                                      hist def inherit-input-method)
530   "Like `completing-read' but reads a nickname."
531   (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match
532                        initial-input hist def inherit-input-method))
533
534 (defun erc-nicknames-list ()
535   "Return all nicknames of all ERC buffers."
536   (if (fboundp 'erc-buffer-list)
537       (loop for buffer in (erc-buffer-list)
538             nconc (with-current-buffer buffer
539                     (loop for user-entry in (mapcar 'car (erc-get-channel-user-list))
540                           collect (elt user-entry 1))))))
541
542 (add-to-list 'org-property-set-functions-alist
543              `(,org-contacts-nickname-property . org-contacts-completing-read-nickname))
544
545 (defun org-contacts-vcard-escape (str)
546   "Escape ; , and \n in STR for use in the VCard format.
547 Thanks to http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el for the regexp."
548   (when str
549     (replace-regexp-in-string "\n" "\\\\n" (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))
550
551 (defun org-contacts-vcard-encode-name (name)
552   "Try to encode NAME as VCard's N property. The N property expects FamilyName;GivenName;AdditionalNames;Prefix;Postfix.
553 Org-contacts does not specify how to encode the name. So we try to do our best."
554   (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;"))
555
556 (defun org-contacts-vcard-format (contact)
557   "Formats CONTACT in VCard 3.0 format."
558   (let* ((properties (caddr contact))
559          (name (org-contacts-vcard-escape (car contact)))
560          (n (org-contacts-vcard-encode-name name))
561          (email (org-contacts-vcard-escape (cdr (assoc-string org-contacts-email-property properties))))
562          (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties))))
563          (addr (cdr (assoc-string org-contacts-address-property properties)))
564          (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties))))
565
566          (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name)))
567     (concat head
568             (when email (format "EMAIL:%s\n" email))
569             (when addr
570               (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
571             (when bday
572               (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday))))
573                 (format "BDAY:%04d-%02d-%02d\n"
574                         (calendar-extract-year cal-bday)
575                         (calendar-extract-month cal-bday)
576                         (calendar-extract-day cal-bday))))
577             (when nick (format "NICKNAME:%s\n" nick))
578             "END:VCARD\n\n")))
579
580 (defun org-contacts-export-as-vcard (&optional name file to-buffer)
581   "Export all contacts matching NAME as VCard 3.0. It TO-BUFFER is nil, the content is written to FILE or `org-contacts-vcard-file'. If TO-BUFFER is non-nil, the buffer is created and the VCard is written into that buffer."
582   (interactive) ; TODO ask for name?
583   (let* ((filename (or file org-contacts-vcard-file))
584          (buffer (if to-buffer
585                      (get-buffer-create to-buffer)
586                      (find-file-noselect filename))))
587
588     (message "Exporting...")
589
590     (set-buffer buffer)
591     (let ((inhibit-read-only t)) (erase-buffer))
592     (fundamental-mode)
593     (org-install-letbind)
594
595     (when (fboundp 'set-buffer-file-coding-system)
596       (set-buffer-file-coding-system coding-system-for-write))
597
598     (loop for contact in (org-contacts-filter name)
599          do (insert (org-contacts-vcard-format contact)))
600
601     (if to-buffer
602         (current-buffer)
603         (progn (save-buffer) (kill-buffer)))))
604
605 (defun org-contacts-show-map (&optional name)
606   "Show contacts on a map. Requires google-maps-el."
607   (interactive)
608   (unless (fboundp 'google-maps-static-show)
609     (error "org-contacts-show-map requires google-maps-el."))
610   (google-maps-static-show
611    :markers
612    (loop
613       for contact in (org-contacts-filter name)
614       for addr = (cdr (assoc-string org-contacts-address-property (caddr contact)))
615       if addr
616       collect (cons (list addr) (list :label (string-to-char (car contact)))))))
617
618 (provide 'org-contacts)