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