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