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