contrib/lisp/org-contacts.el

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