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