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)