contrib/lisp/org-contacts.el

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