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