contrib/lisp/org-contacts.el

   1 ;;; org-contacts.el --- Contacts management
   2
   3 ;; Copyright (C) 2010-2014 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 ;; This program 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 ;; This program 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 minimal 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 ;; You can also use a complex template, for example:
  38 ;;
  39 ;;         ("c" "Contacts" entry (file "~/Org/contacts.org")
  40 ;;          "* %(org-contacts-template-name)
  41 ;; :PROPERTIES:
  42 ;; :EMAIL: %(org-contacts-template-email)
  43 ;; :PHONE:
  44 ;; :ALIAS:
  45 ;; :NICKNAME:
  46 ;; :IGNORE:
  47 ;; :ICON:
  48 ;; :NOTE:
  49 ;; :ADDRESS:
  50 ;; :BIRTHDAY:
  51 ;; :END:")))
  52 ;;
  53 ;;; Code:
  54
  55 (eval-when-compile
  56   (require 'cl))
  57
  58 (require 'org)
  59 (require 'gnus-util)
  60 (require 'gnus-art)
  61 (require 'mail-utils)
  62 (require 'org-agenda)
  63 (require 'org-capture)
  64
  65 (defgroup org-contacts nil
  66   "Options about contacts management."
  67   :group 'org)
  68
  69 (defcustom org-contacts-files nil
  70   "List of Org files to use as contacts source.
  71 When set to nil, all your Org files will be used."
  72   :type '(repeat file)
  73   :group 'org-contacts)
  74
  75 (defcustom org-contacts-email-property "EMAIL"
  76   "Name of the property for contact email address."
  77   :type 'string
  78   :group 'org-contacts)
  79
  80 (defcustom org-contacts-tel-property "PHONE"
  81   "Name of the property for contact phone number."
  82   :type 'string
  83   :group 'org-contacts)
  84
  85 (defcustom org-contacts-address-property "ADDRESS"
  86   "Name of the property for contact address."
  87   :type 'string
  88   :group 'org-contacts)
  89
  90 (defcustom org-contacts-birthday-property "BIRTHDAY"
  91   "Name of the property for contact birthday date."
  92   :type 'string
  93   :group 'org-contacts)
  94
  95 (defcustom org-contacts-note-property "NOTE"
  96   "Name of the property for contact note."
  97   :type 'string
  98   :group 'org-contacts)
  99
 100 (defcustom org-contacts-alias-property "ALIAS"
 101   "Name of the property for contact name alias."
 102   :type 'string
 103   :group 'org-contacts)
 104
 105 (defcustom org-contacts-ignore-property "IGNORE"
 106   "Name of the property, which values will be ignored when
 107 completing or exporting to vcard."
 108   :type 'string
 109   :group 'org-contacts)
 110
 111
 112 (defcustom org-contacts-birthday-format "Birthday: %l (%Y)"
 113   "Format of the anniversary agenda entry.
 114 The following replacements are available:
 115
 116   %h - Heading name
 117   %l - Link to the heading
 118   %y - Number of year
 119   %Y - Number of year (ordinal)"
 120   :type 'string
 121   :group 'org-contacts)
 122
 123 (defcustom org-contacts-last-read-mail-property "LAST_READ_MAIL"
 124   "Name of the property for contact last read email link storage."
 125   :type 'string
 126   :group 'org-contacts)
 127
 128 (defcustom org-contacts-icon-property "ICON"
 129   "Name of the property for contact icon."
 130   :type 'string
 131   :group 'org-contacts)
 132
 133 (defcustom org-contacts-nickname-property "NICKNAME"
 134   "Name of the property for IRC nickname match."
 135   :type 'string
 136   :group 'org-contacts)
 137
 138 (defcustom org-contacts-icon-size 32
 139   "Size of the contacts icons."
 140   :type 'string
 141   :group 'org-contacts)
 142
 143 (defcustom org-contacts-icon-use-gravatar (fboundp 'gravatar-retrieve)
 144   "Whether use Gravatar to fetch contact icons."
 145   :type 'boolean
 146   :group 'org-contacts)
 147
 148 (defcustom org-contacts-completion-ignore-case t
 149   "Ignore case when completing contacts."
 150   :type 'boolean
 151   :group 'org-contacts)
 152
 153 (defcustom org-contacts-group-prefix "+"
 154   "Group prefix."
 155   :type 'string
 156   :group 'org-contacts)
 157
 158 (defcustom org-contacts-matcher
 159   (mapconcat 'identity (list org-contacts-email-property
 160                              org-contacts-alias-property
 161                              org-contacts-tel-property
 162                              org-contacts-address-property
 163                              org-contacts-birthday-property)
 164                              "<>\"\"|")
 165   "Matching rule for finding heading that are contacts.
 166 This can be a tag name, or a property check."
 167   :type 'string
 168   :group 'org-contacts)
 169
 170 (defcustom org-contacts-email-link-description-format "%s (%d)"
 171   "Format used to store links to email.
 172 This overrides `org-email-link-description-format' if set."
 173   :group 'org-contacts
 174   :type 'string)
 175
 176 (defcustom org-contacts-vcard-file "contacts.vcf"
 177   "Default file for vcard export."
 178   :group 'org-contacts
 179   :type 'file)
 180
 181 (defcustom org-contacts-enable-completion t
 182   "Enable or not the completion in `message-mode' with `org-contacts'."
 183   :group 'org-contacts
 184   :type 'boolean)
 185
 186 ;; Decalre external functions and variables
 187 (declare-function org-reverse-string "org")
 188 (declare-function diary-ordinal-suffix "ext:diary-lib")
 189 (declare-function wl-summary-message-number "ext:wl-summary")
 190 (declare-function wl-address-header-extract-address "ext:wl-address")
 191 (declare-function wl-address-header-extract-realname "ext:wl-address")
 192 (declare-function erc-buffer-list "ext:erc")
 193 (declare-function erc-get-channel-user-list "ext:erc")
 194 (declare-function google-maps-static-show "ext:google-maps-static")
 195 (declare-function elmo-message-field "ext:elmo-pipe")
 196 (declare-function std11-narrow-to-header "ext:std11")
 197 (declare-function std11-fetch-field "ext:std11")
 198
 199 (defconst org-contacts-property-values-separators "[,; \f\t\n\r\v]+"
 200   "The default value of separators for `org-contacts-split-property'.
 201
 202 A regexp matching strings of whitespace, `,' and `;'.")
 203
 204 (defvar org-contacts-keymap
 205   (let ((map (make-sparse-keymap)))
 206     (define-key map "M" 'org-contacts-view-send-email)
 207     (define-key map "i" 'org-contacts-view-switch-to-irc-buffer)
 208     map)
 209   "The keymap used in `org-contacts' result list.")
 210
 211 (defvar org-contacts-db nil
 212   "Org Contacts database.")
 213
 214 (defvar org-contacts-last-update nil
 215   "Last time the Org Contacts database has been updated.")
 216
 217 (defun org-contacts-files ()
 218   "Return list of Org files to use for contact management."
 219   (or org-contacts-files (org-agenda-files t 'ifmode)))
 220
 221 (defun org-contacts-db-need-update-p ()
 222   "Determine whether `org-contacts-db' needs to be refreshed."
 223   (or (null org-contacts-last-update)
 224       (org-find-if (lambda (file)
 225                      (or (time-less-p org-contacts-last-update
 226                                       (elt (file-attributes file) 5))))
 227                    (org-contacts-files))
 228       (org-contacts-db-has-dead-markers-p org-contacts-db)))
 229
 230 (defun org-contacts-db-has-dead-markers-p (org-contacts-db)
 231   "Returns t if at least one dead marker is found in
 232 ORG-CONTACTS-DB. A dead marker in this case is a marker pointing
 233 to dead or no buffer."
 234     ;; Scan contacts list looking for dead markers, and return t at first found.
 235     (catch 'dead-marker-found
 236       (while org-contacts-db
 237         (unless (marker-buffer (nth 1 (car org-contacts-db)))
 238           (throw 'dead-marker-found t))
 239         (setq org-contacts-db (cdr org-contacts-db)))
 240       nil))
 241
 242 (defun org-contacts-db ()
 243   "Return the latest Org Contacts Database."
 244   (let* (todo-only
 245          (contacts-matcher
 246           (cdr (org-make-tags-matcher org-contacts-matcher)))
 247          markers result)
 248     (when (org-contacts-db-need-update-p)
 249       (let ((progress-reporter
 250              (make-progress-reporter "Updating Org Contacts Database..." 0 (length org-contacts-files)))
 251             (i 0))
 252         (dolist (file (org-contacts-files))
 253           (org-check-agenda-file file)
 254           (with-current-buffer (org-get-agenda-file-buffer file)
 255             (unless (eq major-mode 'org-mode)
 256               (error "File %s is no in `org-mode'" file))
 257             (org-scan-tags
 258              '(add-to-list 'markers (set-marker (make-marker) (point)))
 259              contacts-matcher
 260              todo-only))
 261           (progress-reporter-update progress-reporter (setq i (1+ i))))
 262         (dolist (marker markers result)
 263           (org-with-point-at marker
 264             (add-to-list 'result
 265                          (list (org-get-heading t) marker (org-entry-properties marker 'all)))))
 266         (setf org-contacts-db result
 267               org-contacts-last-update (current-time))
 268       (progress-reporter-done progress-reporter)))
 269     org-contacts-db))
 270
 271 (defun org-contacts-filter (&optional name-match tags-match prop-match)
 272   "Search for a contact matching any of NAME-MATCH, TAGS-MATCH, PROP-MATCH.
 273 If all match values are nil, return all contacts.
 274
 275 The optional PROP-MATCH argument is a single (PROP . VALUE) cons
 276 cell corresponding to the contact properties.
 277 "
 278   (if (and (null name-match)
 279            (null prop-match)
 280            (null tags-match))
 281       (org-contacts-db)
 282     (loop for contact in (org-contacts-db)
 283           if (or
 284               (and name-match
 285                    (org-string-match-p name-match
 286                                        (first contact)))
 287               (and prop-match
 288                    (org-find-if (lambda (prop)
 289                                   (and (string= (car prop-match) (car prop))
 290                                        (org-string-match-p (cdr prop-match) (cdr prop))))
 291                                 (caddr contact)))
 292               (and tags-match
 293                    (org-find-if (lambda (tag)
 294                                   (org-string-match-p tags-match tag))
 295                                 (org-split-string
 296                                  (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
 297           collect contact)))
 298
 299 (when (not (fboundp 'completion-table-case-fold))
 300   ;; That function is new in Emacs 24...
 301   (defun completion-table-case-fold (table &optional dont-fold)
 302     (lambda (string pred action)
 303       (let ((completion-ignore-case (not dont-fold)))
 304         (complete-with-action action table string pred)))))
 305
 306 (defun org-contacts-try-completion-prefix (to-match collection &optional predicate)
 307   "Custom implementation of `try-completion'.
 308 This version works only with list and alist and it looks at all
 309 prefixes rather than just the beginning of the string."
 310   (loop with regexp = (concat "\\b" (regexp-quote to-match))
 311         with ret = nil
 312         with ret-start = nil
 313         with ret-end = nil
 314
 315         for el in collection
 316         for string = (if (listp el) (car el) el)
 317
 318         for start = (when (or (null predicate) (funcall predicate string))
 319                       (string-match regexp string))
 320
 321         if start
 322         do (let ((end (match-end 0))
 323                  (len (length string)))
 324              (if (= end len)
 325                  (return t)
 326                (destructuring-bind (string start end)
 327                    (if (null ret)
 328                        (values string start end)
 329                      (org-contacts-common-substring
 330                       ret ret-start ret-end
 331                       string start end))
 332                  (setf ret string
 333                        ret-start start
 334                        ret-end end))))
 335
 336         finally (return
 337                  (replace-regexp-in-string "\\`[ \t\n]*" "" ret))))
 338
 339 (defun org-contacts-compare-strings (s1 start1 end1 s2 start2 end2 &optional ignore-case)
 340   "Compare the contents of two strings, using `compare-strings'.
 341
 342 This function works like `compare-strings' excepted that it
 343 returns a cons.
 344 - The CAR is the number of characters that match at the beginning.
 345 - The CDR is T is the two strings are the same and NIL otherwise."
 346   (let ((ret (compare-strings s1 start1 end1 s2 start2 end2 ignore-case)))
 347     (if (eq ret t)
 348         (cons (or end1 (length s1)) t)
 349       (cons (1- (abs ret)) nil))))
 350
 351 (defun org-contacts-common-substring (s1 start1 end1 s2 start2 end2)
 352   "Extract the common substring between S1 and S2.
 353
 354 This function extracts the common substring between S1 and S2 and
 355 adjust the part that remains common.
 356
 357 START1 and END1 delimit the part in S1 that we know is common
 358 between the two strings. This applies to START2 and END2 for S2.
 359
 360 This function returns a list whose contains:
 361 - The common substring found.
 362 - The new value of the start of the known inner substring.
 363 - The new value of the end of the known inner substring."
 364   ;; Given two strings:
 365   ;; s1: "foo bar baz"
 366   ;; s2: "fooo bar baz"
 367   ;; and the inner substring is "bar"
 368   ;; then: start1 = 4, end1 = 6, start2 = 5, end2 = 7
 369   ;;
 370   ;; To find the common substring we will compare two substrings:
 371   ;; " oof" and " ooof" to find the beginning of the common substring.
 372   ;; " baz" and " baz" to find the end of the common substring.
 373   (let* ((len1 (length s1))
 374          (start1 (or start1 0))
 375          (end1 (or end1 len1))
 376
 377          (len2 (length s2))
 378          (start2 (or start2 0))
 379          (end2 (or end2 len2))
 380
 381          (new-start (car (org-contacts-compare-strings
 382                           (substring (org-reverse-string s1) (- len1 start1)) nil nil
 383                           (substring (org-reverse-string s2) (- len2 start2)) nil nil)))
 384
 385          (new-end (+ end1 (car (org-contacts-compare-strings
 386                                 (substring s1 end1) nil nil
 387                                 (substring s2 end2) nil nil)))))
 388     (list (substring s1 (- start1 new-start) new-end)
 389           new-start
 390           (+ new-start (- end1 start1)))))
 391
 392 (defun org-contacts-all-completions-prefix (to-match collection &optional predicate)
 393   "Custom version of `all-completions'.
 394 This version works only with list and alist and it looks at all
 395 prefixes rather than just the beginning of the string."
 396   (loop with regexp = (concat "\\b" (regexp-quote to-match))
 397         for el in collection
 398         for string = (if (listp el) (car el) el)
 399         for match? = (when (and (or (null predicate) (funcall predicate string)))
 400                        (string-match regexp string))
 401         if match?
 402         collect (progn
 403                   (let ((end (match-end 0)))
 404                     (org-no-properties string)
 405                     (when (< end (length string))
 406                       ;; Here we add a text property that will be used
 407                       ;; later to highlight the character right after
 408                       ;; the common part between each addresses.
 409                       ;; See `org-contacts-display-sort-function'.
 410                       (put-text-property end (1+ end) 'org-contacts-prefix 't string)))
 411                   string)))
 412
 413 (defun org-contacts-make-collection-prefix (collection)
 414   "Make a collection function from COLLECTION which will match on prefixes."
 415   (lexical-let ((collection collection))
 416     (lambda (string predicate flag)
 417       (cond ((eq flag nil)
 418              (org-contacts-try-completion-prefix string collection predicate))
 419             ((eq flag t)
 420              ;; `org-contacts-all-completions-prefix' has already been
 421              ;; used to compute `all-completions'.
 422              collection)
 423             ((eq flag 'lambda)
 424              (org-contacts-test-completion-prefix string collection predicate))
 425             ((and (listp flag) (eq (car flag) 'boundaries))
 426              (destructuring-bind (to-ignore &rest suffix)
 427                  flag
 428                (org-contacts-boundaries-prefix string collection predicate suffix)))
 429             ((eq flag 'metadata)
 430              (org-contacts-metadata-prefix string collection predicate))
 431             (t nil                      ; operation unsupported
 432                )))))
 433
 434 (defun org-contacts-display-sort-function (completions)
 435   "Sort function for contacts display."
 436   (mapcar (lambda (string)
 437             (loop with len = (1- (length string))
 438                   for i upfrom 0 to len
 439                   if (memq 'org-contacts-prefix
 440                            (text-properties-at i string))
 441                   do (set-text-properties
 442                       i (1+ i)
 443                       (list 'font-lock-face
 444                             (if (char-equal (aref string i)
 445                                             (string-to-char " "))
 446                                 ;; Spaces can't be bold.
 447                                 'underline
 448                               'bold)) string)
 449                   else
 450                   do (set-text-properties i (1+ i) nil string)
 451                   finally (return string)))
 452           completions))
 453
 454 (defun org-contacts-test-completion-prefix (string collection predicate)
 455   ;; Prevents `org-find-if' from redefining `predicate' and going into
 456   ;; an infinite loop.
 457   (lexical-let ((predicate predicate))
 458     (org-find-if (lambda (el)
 459                    (and (or (null predicate) (funcall predicate el))
 460                         (string= string el)))
 461                  collection)))
 462
 463 (defun org-contacts-boundaries-prefix (string collection predicate suffix)
 464   (list* 'boundaries (completion-boundaries string collection predicate suffix)))
 465
 466 (defun org-contacts-metadata-prefix (string collection predicate)
 467   '(metadata .
 468              ((cycle-sort-function . org-contacts-display-sort-function)
 469               (display-sort-function . org-contacts-display-sort-function))))
 470
 471 (defun org-contacts-complete-group (start end string)
 472   "Complete text at START from a group.
 473
 474 A group FOO is composed of contacts with the tag FOO."
 475   (let* ((completion-ignore-case org-contacts-completion-ignore-case)
 476          (group-completion-p (org-string-match-p
 477                               (concat "^" org-contacts-group-prefix) string)))
 478     (when group-completion-p
 479       (let ((completion-list
 480              (all-completions
 481               string
 482               (mapcar (lambda (group)
 483                         (propertize (concat org-contacts-group-prefix group)
 484                                     'org-contacts-group group))
 485                       (org-uniquify
 486                        (loop for contact in (org-contacts-filter)
 487                              nconc (org-split-string
 488                                     (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))))))
 489         (list start end
 490               (if (= (length completion-list) 1)
 491                   ;; We've found the correct group, returns the address
 492                   (lexical-let ((tag (get-text-property 0 'org-contacts-group
 493                                                         (car completion-list))))
 494                     (lambda (string pred &optional to-ignore)
 495                       (mapconcat 'identity
 496                                  (loop for contact in (org-contacts-filter
 497                                                        nil
 498                                                        tag)
 499                                        ;; The contact name is always the car of the assoc-list
 500                                        ;; returned by `org-contacts-filter'.
 501                                        for contact-name = (car contact)
 502                                        ;; Grab the first email of the contact
 503                                        for email = (org-contacts-strip-link (car (org-contacts-split-property
 504                                                          (or
 505                                                           (cdr (assoc-string org-contacts-email-property
 506                                                                              (caddr contact)))
 507                                                           ""))))
 508                                        ;; If the user has an email address, append USER <EMAIL>.
 509                                        if email collect (org-contacts-format-email contact-name email))
 510                                  ", ")))
 511                 ;; We haven't found the correct group
 512                 (completion-table-case-fold completion-list
 513                                             (not org-contacts-completion-ignore-case))))))))
 514
 515
 516 (defun org-contacts-remove-ignored-property-values (ignore-list list)
 517   "Remove all ignore-list's elements from list and you can use
 518    regular expressions in the ignore list."
 519     (org-remove-if (lambda (el)
 520                      (org-find-if (lambda (x)
 521                                     (string-match-p x el))
 522                                   ignore-list))
 523                    list))
 524
 525 (defun org-contacts-complete-name (start end string)
 526   "Complete text at START with a user name and email."
 527   (let* ((completion-ignore-case org-contacts-completion-ignore-case)
 528          (completion-list
 529           (loop for contact in (org-contacts-filter)
 530                 ;; The contact name is always the car of the assoc-list
 531                 ;; returned by `org-contacts-filter'.
 532                 for contact-name = (car contact)
 533
 534                 ;; Build the list of the email addresses which has
 535                 ;; been expired
 536                 for ignore-list = (org-contacts-split-property
 537                                    (or (cdr (assoc-string org-contacts-ignore-property
 538                                                           (caddr contact))) ""))
 539                 ;; Build the list of the user email addresses.
 540                 for email-list = (org-contacts-remove-ignored-property-values
 541                                   ignore-list
 542                                   (org-contacts-split-property
 543                                    (or (cdr (assoc-string org-contacts-email-property
 544                                                           (caddr contact))) "")))
 545                 ;; If the user has email addresses…
 546                 if email-list
 547                 ;; … append a list of USER <EMAIL>.
 548                 nconc (loop for email in email-list
 549                             collect (org-contacts-format-email contact-name (org-contacts-strip-link email)))))
 550          (completion-list (org-contacts-all-completions-prefix
 551                            string
 552                            (org-uniquify completion-list))))
 553     (when completion-list
 554       (list start end
 555             (org-contacts-make-collection-prefix completion-list)))))
 556
 557 (defun org-contacts-message-complete-function (&optional start)
 558   "Function used in `completion-at-point-functions' in `message-mode'."
 559   ;; Avoid to complete in `post-command-hook'.
 560   (when completion-in-region-mode
 561     (remove-hook 'post-command-hook #'completion-in-region--postch))
 562   (let ((mail-abbrev-mode-regexp
 563          "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
 564     (when (mail-abbrev-in-expansion-header-p)
 565       (lexical-let*
 566           ((end (point))
 567            (start (or start
 568                       (save-excursion
 569                         (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 570                         (goto-char (match-end 0))
 571                         (point))))
 572            (string (buffer-substring start end)))
 573         (or (org-contacts-complete-group start end string)
 574             (org-contacts-complete-name start end string))))))
 575
 576 (defun org-contacts-gnus-get-name-email ()
 577   "Get name and email address from Gnus message."
 578   (if (gnus-alive-p)
 579       (gnus-with-article-headers
 580         (mail-extract-address-components
 581          (or (mail-fetch-field "From") "")))))
 582
 583 (defun org-contacts-gnus-article-from-get-marker ()
 584   "Return a marker for a contact based on From."
 585   (let* ((address (org-contacts-gnus-get-name-email))
 586          (name (car address))
 587          (email (cadr address)))
 588     (cadar (or (org-contacts-filter
 589                 nil
 590                 nil
 591                 (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b")))
 592                (when name
 593                  (org-contacts-filter
 594                   (concat "^" name "$")))))))
 595
 596 (defun org-contacts-gnus-article-from-goto ()
 597   "Go to contact in the From address of current Gnus message."
 598   (interactive)
 599   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 600     (when marker
 601       (switch-to-buffer-other-window (marker-buffer marker))
 602       (goto-char marker)
 603       (when (eq major-mode 'org-mode)
 604         (org-show-context 'agenda)
 605         (save-excursion
 606           (and (outline-next-heading)
 607                ;; show the next heading
 608                (org-flag-heading nil)))))))
 609
 610 (org-no-warnings (defvar date)) ;; unprefixed, from calendar.el
 611 (defun org-contacts-anniversaries (&optional field format)
 612   "Compute FIELD anniversary for each contact, returning FORMAT.
 613 Default FIELD value is \"BIRTHDAY\".
 614
 615 Format is a string matching the following format specification:
 616
 617   %h - Heading name
 618   %l - Link to the heading
 619   %y - Number of year
 620   %Y - Number of year (ordinal)"
 621   (let ((calendar-date-style 'american)
 622         (entry ""))
 623     (unless format (setq format org-contacts-birthday-format))
 624     (loop for contact in (org-contacts-filter)
 625           for anniv = (let ((anniv (cdr (assoc-string
 626                                          (or field org-contacts-birthday-property)
 627                                          (caddr contact)))))
 628                         (when anniv
 629                           (calendar-gregorian-from-absolute
 630                            (org-time-string-to-absolute anniv))))
 631           ;; Use `diary-anniversary' to compute anniversary.
 632           if (and anniv (apply 'diary-anniversary anniv))
 633           collect (format-spec format
 634                                `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
 635                                  (?h . ,(car contact))
 636                                  (?y . ,(- (calendar-extract-year date)
 637                                            (calendar-extract-year anniv)))
 638                                  (?Y . ,(let ((years (- (calendar-extract-year date)
 639                                                         (calendar-extract-year anniv))))
 640                                           (format "%d%s" years (diary-ordinal-suffix years)))))))))
 641
 642 (defun org-completing-read-date (prompt collection
 643                                         &optional predicate require-match initial-input
 644                                         hist def inherit-input-method)
 645   "Like `completing-read' but reads a date.
 646 Only PROMPT and DEF are really used."
 647   (org-read-date nil nil nil prompt nil def))
 648
 649 (add-to-list 'org-property-set-functions-alist
 650              `(,org-contacts-birthday-property . org-completing-read-date))
 651
 652 (defun org-contacts-template-name (&optional return-value)
 653   "Try to return the contact name for a template.
 654 If not found return RETURN-VALUE or something that would ask the user."
 655   (or (car (org-contacts-gnus-get-name-email))
 656       return-value
 657       "%^{Name}"))
 658
 659 (defun org-contacts-template-email (&optional return-value)
 660   "Try to return the contact email for a template.
 661 If not found return RETURN-VALUE or something that would ask the user."
 662   (or (cadr (org-contacts-gnus-get-name-email))
 663       return-value
 664       (concat "%^{" org-contacts-email-property "}p")))
 665
 666 (defun org-contacts-gnus-store-last-mail ()
 667   "Store a link between mails and contacts.
 668
 669 This function should be called from `gnus-article-prepare-hook'."
 670   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 671     (when marker
 672       (with-current-buffer (marker-buffer marker)
 673         (save-excursion
 674           (goto-char marker)
 675           (let* ((org-email-link-description-format (or org-contacts-email-link-description-format
 676                                                         org-email-link-description-format))
 677                  (link (gnus-with-article-buffer (org-store-link nil))))
 678             (org-set-property org-contacts-last-read-mail-property link)))))))
 679
 680 (defun org-contacts-icon-as-string ()
 681   "Return the contact icon as a string."
 682   (let ((image (org-contacts-get-icon)))
 683     (concat
 684      (propertize "-" 'display
 685                  (append
 686                   (if image
 687                       image
 688                     `'(space :width (,org-contacts-icon-size)))
 689                   '(:ascent center)))
 690      " ")))
 691
 692 ;;;###autoload
 693 (defun org-contacts (name)
 694   "Create agenda view for contacts matching NAME."
 695   (interactive (list (read-string "Name: ")))
 696   (let ((org-agenda-files (org-contacts-files))
 697         (org-agenda-skip-function
 698          (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
 699         (org-agenda-prefix-format (propertize
 700                                    "%(org-contacts-icon-as-string)% s%(org-contacts-irc-number-of-unread-messages) "
 701                                    'keymap org-contacts-keymap))
 702         (org-agenda-overriding-header
 703          (or org-agenda-overriding-header
 704              (concat "List of contacts matching `" name "':"))))
 705     (setq org-agenda-skip-regexp name)
 706     (org-tags-view nil org-contacts-matcher)
 707     (with-current-buffer org-agenda-buffer-name
 708       (setq org-agenda-redo-command
 709             (list 'org-contacts name)))))
 710
 711 (defun org-contacts-completing-read (prompt
 712                                      &optional predicate
 713                                      initial-input hist def inherit-input-method)
 714   "Call `completing-read' with contacts name as collection."
 715   (org-completing-read
 716    prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method))
 717
 718 (defun org-contacts-format-name (name)
 719   "Trim any local formatting to get a bare NAME."
 720   ;; Remove radio targets characters
 721   (replace-regexp-in-string org-radio-target-regexp "\\1" name))
 722
 723 (defun org-contacts-format-email (name email)
 724   "Format an EMAIL address corresponding to NAME."
 725   (unless email
 726     (error "`email' cannot be nul"))
 727   (if name
 728       (concat (org-contacts-format-name name) " <" email ">")
 729     email))
 730
 731 (defun org-contacts-check-mail-address (mail)
 732   "Add MAIL address to contact at point if it does not have it."
 733   (let ((mails (org-entry-get (point) org-contacts-email-property)))
 734     (unless (member mail (split-string mails))
 735       (when (yes-or-no-p
 736              (format "Do you want to add this address to %s?" (org-get-heading t)))
 737         (org-set-property org-contacts-email-property (concat mails " " mail))))))
 738
 739 (defun org-contacts-gnus-check-mail-address ()
 740   "Check that contact has the current address recorded.
 741 This function should be called from `gnus-article-prepare-hook'."
 742   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 743     (when marker
 744       (org-with-point-at marker
 745         (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))
 746
 747 (defun org-contacts-gnus-insinuate ()
 748   "Add some hooks for Gnus user.
 749 This adds `org-contacts-gnus-check-mail-address' and
 750 `org-contacts-gnus-store-last-mail' to
 751 `gnus-article-prepare-hook'.  It also adds a binding on `;' in
 752 `gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
 753   (require 'gnus)
 754   (require 'gnus-art)
 755   (define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto)
 756   (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address)
 757   (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail))
 758
 759 (defun org-contacts-setup-completion-at-point ()
 760   "Add `org-contacts-message-complete-function' as a new function
 761 to complete the thing at point."
 762   (add-to-list 'completion-at-point-functions
 763                'org-contacts-message-complete-function))
 764
 765 (defun org-contacts-unload-hook ()
 766   (remove-hook 'message-mode-hook 'org-contacts-setup-completion-at-point))
 767
 768 (when (and org-contacts-enable-completion
 769            (boundp 'completion-at-point-functions))
 770   (add-hook 'message-mode-hook 'org-contacts-setup-completion-at-point))
 771
 772 (defun org-contacts-wl-get-from-header-content ()
 773   "Retrieve the content of the `From' header of an email.
 774 Works from wl-summary-mode and mime-view-mode - that is while viewing email.
 775 Depends on Wanderlust been loaded."
 776   (with-current-buffer (org-capture-get :original-buffer)
 777     (cond
 778      ((eq major-mode 'wl-summary-mode) (when (and (boundp 'wl-summary-buffer-elmo-folder)
 779                                                   wl-summary-buffer-elmo-folder)
 780                                          (elmo-message-field
 781                                           wl-summary-buffer-elmo-folder
 782                                           (wl-summary-message-number)
 783                                           'from)))
 784      ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
 785       (prog1
 786           (std11-fetch-field "From")
 787         (widen))))))
 788
 789 (defun org-contacts-wl-get-name-email ()
 790   "Get name and email address from Wanderlust email.
 791 See `org-contacts-wl-get-from-header-content' for limitations."
 792   (let ((from (org-contacts-wl-get-from-header-content)))
 793     (when from
 794       (list (wl-address-header-extract-realname from)
 795             (wl-address-header-extract-address from)))))
 796
 797 (defun org-contacts-template-wl-name (&optional return-value)
 798   "Try to return the contact name for a template from wl.
 799 If not found, return RETURN-VALUE or something that would ask the
 800 user."
 801   (or (car (org-contacts-wl-get-name-email))
 802       return-value
 803       "%^{Name}"))
 804
 805 (defun org-contacts-template-wl-email (&optional return-value)
 806   "Try to return the contact email for a template from Wanderlust.
 807 If not found return RETURN-VALUE or something that would ask the user."
 808   (or (cadr (org-contacts-wl-get-name-email))
 809       return-value
 810       (concat "%^{" org-contacts-email-property "}p")))
 811
 812 (defun org-contacts-view-send-email (&optional ask)
 813   "Send email to the contact at point.
 814 If ASK is set, ask for the email address even if there's only one
 815 address."
 816   (interactive "P")
 817   (let ((marker (org-get-at-bol 'org-hd-marker)))
 818     (org-with-point-at marker
 819       (let ((emails (org-entry-get (point) org-contacts-email-property)))
 820         (if emails
 821             (let ((email-list (org-contacts-split-property emails)))
 822               (if (and (= (length email-list) 1) (not ask))
 823                   (compose-mail (org-contacts-format-email
 824                                  (org-get-heading t) emails))
 825                 (let ((email (completing-read "Send mail to which address: " email-list)))
 826                   (setq email (org-contacts-strip-link email))
 827                   (org-contacts-check-mail-address email)
 828                   (compose-mail (org-contacts-format-email (org-get-heading t) email)))))
 829           (error (format "This contact has no mail address set (no %s property)."
 830                          org-contacts-email-property)))))))
 831
 832 (defun org-contacts-get-icon (&optional pom)
 833   "Get icon for contact at POM."
 834   (setq pom (or pom (point)))
 835   (catch 'icon
 836     ;; Use `org-contacts-icon-property'
 837     (let ((image-data (org-entry-get pom org-contacts-icon-property)))
 838       (when image-data
 839         (throw 'icon
 840                (if (fboundp 'gnus-rescale-image)
 841                    (gnus-rescale-image (create-image image-data)
 842                                        (cons org-contacts-icon-size org-contacts-icon-size))
 843                  (create-image image-data)))))
 844     ;; Next, try Gravatar
 845     (when org-contacts-icon-use-gravatar
 846       (let* ((gravatar-size org-contacts-icon-size)
 847              (email-list (org-entry-get pom org-contacts-email-property))
 848              (gravatar
 849               (when email-list
 850                 (loop for email in (org-contacts-split-property email-list)
 851                       for gravatar = (gravatar-retrieve-synchronously (org-contacts-strip-link email))
 852                       if (and gravatar
 853                               (not (eq gravatar 'error)))
 854                       return gravatar))))
 855         (when gravatar (throw 'icon gravatar))))))
 856
 857 (defun org-contacts-irc-buffer (&optional pom)
 858   "Get the IRC buffer associated with the entry at POM."
 859   (setq pom (or pom (point)))
 860   (let ((nick (org-entry-get pom org-contacts-nickname-property)))
 861     (when nick
 862       (let ((buffer (get-buffer nick)))
 863         (when buffer
 864           (with-current-buffer buffer
 865             (when (eq major-mode 'erc-mode)
 866               buffer)))))))
 867
 868 (defun org-contacts-irc-number-of-unread-messages (&optional pom)
 869   "Return the number of unread messages for contact at POM."
 870   (when (boundp 'erc-modified-channels-alist)
 871     (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist))))
 872       (if number
 873           (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number)
 874         (make-string 21 ? )))))
 875
 876 (defun org-contacts-view-switch-to-irc-buffer ()
 877   "Switch to the IRC buffer of the current contact if it has one."
 878   (interactive)
 879   (let ((marker (org-get-at-bol 'org-hd-marker)))
 880     (org-with-point-at marker
 881       (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
 882
 883 (defun org-contacts-completing-read-nickname (prompt collection
 884                                                      &optional predicate require-match initial-input
 885                                                      hist def inherit-input-method)
 886   "Like `completing-read' but reads a nickname."
 887   (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match
 888                        initial-input hist def inherit-input-method))
 889
 890 (defun erc-nicknames-list ()
 891   "Return all nicknames of all ERC buffers."
 892   (loop for buffer in (erc-buffer-list)
 893         nconc (with-current-buffer buffer
 894                 (loop for user-entry in (mapcar 'car (erc-get-channel-user-list))
 895                       collect (elt user-entry 1)))))
 896
 897 (add-to-list 'org-property-set-functions-alist
 898              `(,org-contacts-nickname-property . org-contacts-completing-read-nickname))
 899
 900 (defun org-contacts-vcard-escape (str)
 901   "Escape ; , and \n in STR for the VCard format."
 902   ;; Thanks to this library for the regexp:
 903   ;; http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el
 904   (when str
 905     (replace-regexp-in-string
 906      "\n" "\\\\n"
 907      (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))
 908
 909 (defun org-contacts-vcard-encode-name (name)
 910   "Try to encode NAME as VCard's N property.
 911 The N property expects
 912
 913   FamilyName;GivenName;AdditionalNames;Prefix;Postfix.
 914
 915 Org-contacts does not specify how to encode the name.  So we try
 916 to do our best."
 917   (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;"))
 918
 919 (defun org-contacts-vcard-format (contact)
 920   "Formats CONTACT in VCard 3.0 format."
 921   (let* ((properties (caddr contact))
 922          (name (org-contacts-vcard-escape (car contact)))
 923          (n (org-contacts-vcard-encode-name name))
 924          (email (cdr (assoc-string org-contacts-email-property properties)))
 925          (tel (cdr (assoc-string org-contacts-tel-property properties)))
 926          (ignore-list (cdr (assoc-string org-contacts-ignore-property properties)))
 927          (ignore-list (when ignore-list
 928                         (org-contacts-split-property ignore-list)))
 929          (note (cdr (assoc-string org-contacts-note-property properties)))
 930          (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties))))
 931          (addr (cdr (assoc-string org-contacts-address-property properties)))
 932          (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties))))
 933          (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name))
 934          emails-list result phones-list)
 935     (concat head
 936             (when email (progn
 937                           (setq emails-list (org-contacts-remove-ignored-property-values ignore-list (org-contacts-split-property email)))
 938                           (setq result "")
 939                           (while emails-list
 940                             (setq result (concat result  "EMAIL:" (org-contacts-strip-link (car emails-list)) "\n"))
 941                             (setq emails-list (cdr emails-list)))
 942                           result))
 943             (when addr
 944               (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
 945             (when tel (progn
 946                         (setq phones-list (org-contacts-remove-ignored-property-values ignore-list (org-contacts-split-property tel)))
 947                         (setq result "")
 948                         (while phones-list
 949                           (setq result (concat result  "TEL:" (org-contacts-strip-link (car phones-list)) "\n"))
 950                           (setq phones-list (cdr phones-list)))
 951                         result))
 952             (when bday
 953               (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday))))
 954                 (format "BDAY:%04d-%02d-%02d\n"
 955                         (calendar-extract-year cal-bday)
 956                         (calendar-extract-month cal-bday)
 957                         (calendar-extract-day cal-bday))))
 958             (when nick (format "NICKNAME:%s\n" nick))
 959             (when note (format "NOTE:%s\n" note))
 960             "END:VCARD\n\n")))
 961
 962 (defun org-contacts-export-as-vcard (&optional name file to-buffer)
 963   "Export all contacts matching NAME as VCard 3.0.
 964 If TO-BUFFER is nil, the content is written to FILE or
 965 `org-contacts-vcard-file'.  If TO-BUFFER is non-nil, the buffer
 966 is created and the VCard is written into that buffer."
 967   (interactive) ; TODO ask for name?
 968   (let* ((filename (or file org-contacts-vcard-file))
 969          (buffer (if to-buffer
 970                      (get-buffer-create to-buffer)
 971                    (find-file-noselect filename))))
 972     (message "Exporting...")
 973     (set-buffer buffer)
 974     (let ((inhibit-read-only t)) (erase-buffer))
 975     (fundamental-mode)
 976     (when (fboundp 'set-buffer-file-coding-system)
 977       (set-buffer-file-coding-system coding-system-for-write))
 978     (loop for contact in (org-contacts-filter name)
 979           do (insert (org-contacts-vcard-format contact)))
 980     (if to-buffer
 981         (current-buffer)
 982       (progn (save-buffer) (kill-buffer)))))
 983
 984 (defun org-contacts-show-map (&optional name)
 985   "Show contacts on a map.
 986 Requires google-maps-el."
 987   (interactive)
 988   (unless (fboundp 'google-maps-static-show)
 989     (error "`org-contacts-show-map' requires `google-maps-el'"))
 990   (google-maps-static-show
 991    :markers
 992    (loop
 993     for contact in (org-contacts-filter name)
 994     for addr = (cdr (assoc-string org-contacts-address-property (caddr contact)))
 995     if addr
 996     collect (cons (list addr) (list :label (string-to-char (car contact)))))))
 997
 998 (defun org-contacts-strip-link (link)
 999   "Remove brackets, description, link type and colon from an org
1000 link string and return the pure link target."
1001    (let (startpos colonpos endpos)
1002      (setq startpos (string-match (regexp-opt '("[[tel:" "[[mailto:")) link))
1003      (if startpos
1004          (progn
1005             (setq colonpos (string-match ":" link))
1006             (setq endpos (string-match "\\]" link))
1007             (if endpos (substring link (1+ colonpos) endpos) link))
1008          (progn
1009             (setq startpos (string-match "mailto:" link))
1010             (setq colonpos (string-match ":" link))
1011             (if startpos (substring link (1+ colonpos)) link)))))
1012
1013 (defun org-contacts-split-property (string &optional separators omit-nulls)
1014   "Custom version of `split-string'.
1015 Split a property STRING into sub-strings bounded by matches
1016 for SEPARATORS but keep Org links intact.
1017
1018 The beginning and end of STRING, and each match for SEPARATORS, are
1019 splitting points.  The substrings matching SEPARATORS are removed, and
1020 the substrings between the splitting points are collected as a list,
1021 which is returned.
1022
1023 If SEPARATORS is non-nil, it should be a regular expression
1024 matching text which separates, but is not part of, the
1025 substrings.  If nil it defaults to `org-contacts-property-values-separators',
1026 normally \"[,; \f\t\n\r\v]+\", and OMIT-NULLS is forced to t.
1027
1028 If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
1029 that for the default value of SEPARATORS leading and trailing whitespace
1030 are effectively trimmed).  If nil, all zero-length substrings are retained."
1031   (let* ((omit-nulls (if separators omit-nulls t))
1032          (rexp (or separators org-contacts-property-values-separators))
1033          (inputlist (split-string string rexp omit-nulls))
1034          (linkstring "")
1035          (bufferstring "")
1036          (proplist (list "")))
1037     (while inputlist
1038       (setq bufferstring (pop inputlist))
1039       (if (string-match "\\[\\[" bufferstring)
1040           (progn
1041             (setq linkstring (concat bufferstring " "))
1042             (while (not (string-match "\\]\\]" bufferstring))
1043               (setq bufferstring (pop inputlist))
1044               (setq linkstring (concat  linkstring bufferstring " ")))
1045             (setq proplist (cons (org-trim linkstring) proplist)))
1046         (setq proplist (cons bufferstring proplist))))
1047     (cdr (reverse proplist))))
1048
1049 (provide 'org-contacts)
1050
1051 ;;; org-contacts.el ends here