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