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 (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       (org-find-if (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                    (org-find-if (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   ;; Prevents `org-find-if' from redefining `predicate' and going into
 373   ;; an infinite loop.
 374   (lexical-let ((predicate predicate))
 375     (org-find-if (lambda (el)
 376                    (and (or (null predicate) (funcall predicate el))
 377                         (string= string el)))
 378                  collection)))
 379
 380 (defun org-contacts-boundaries-prefix (string collection predicate suffix)
 381   (list* 'boundaries (completion-boundaries string collection predicate suffix)))
 382
 383 (defun org-contacts-metadata-prefix (string collection predicate)
 384   '(metadata .
 385              ((display-sort-function . org-contacts-display-sort-function))))
 386
 387 (defun org-contacts-complete-group (start end string)
 388   "Complete text at START from a group.
 389
 390 A group FOO is composed of contacts with the tag FOO."
 391   (let* ((completion-ignore-case org-contacts-completion-ignore-case)
 392          (group-completion-p (org-string-match-p
 393                               (concat "^" org-contacts-group-prefix) string)))
 394     (when group-completion-p
 395       (let ((completion-list
 396              (all-completions
 397               string
 398               (mapcar (lambda (group)
 399                         (propertize (concat org-contacts-group-prefix group)
 400                                     'org-contacts-group group))
 401                       (org-uniquify
 402                        (loop for contact in (org-contacts-filter)
 403                              nconc (org-split-string
 404                                     (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))))))
 405         (list start end
 406               (if (= (length completion-list) 1)
 407                   ;; We've foudn the correct group, returns the address
 408                   (lexical-let ((tag (get-text-property 0 'org-contacts-group
 409                                                         (car completion-list))))
 410                     (lambda (string pred &optional to-ignore)
 411                       (mapconcat 'identity
 412                                  (loop for contact in (org-contacts-filter
 413                                                        nil
 414                                                        tag)
 415                                        ;; The contact name is always the car of the assoc-list
 416                                        ;; returned by `org-contacts-filter'.
 417                                        for contact-name = (car contact)
 418                                        ;; Grab the first email of the contact
 419                                        for email = (car (split-string
 420                                                          (or
 421                                                           (cdr (assoc-string org-contacts-email-property
 422                                                                              (caddr contact)))
 423                                                           "")))
 424                                        ;; If the user has an email address, append USER <EMAIL>.
 425                                        if email collect (org-contacts-format-email contact-name email))
 426                                  ", ")))
 427                 ;; We haven't found the correct group
 428                 (completion-table-case-fold completion-list
 429                                             (not org-contacts-completion-ignore-case))))))))
 430
 431 (defun org-contacts-complete-name (start end string)
 432   "Complete text at START with a user name and email."
 433   (let* ((completion-ignore-case org-contacts-completion-ignore-case)
 434          (completion-list
 435           (loop for contact in (org-contacts-filter)
 436                 ;; The contact name is always the car of the assoc-list
 437                 ;; returned by `org-contacts-filter'.
 438                 for contact-name = (car contact)
 439                 ;; Build the list of the user email addresses.
 440                 for email-list = (split-string (or
 441                                                 (cdr (assoc-string org-contacts-email-property
 442                                                                    (caddr contact))) ""))
 443                 ;; If the user has email addresses…
 444                 if email-list
 445                 ;; … append a list of USER <EMAIL>.
 446                 nconc (loop for email in email-list
 447                             collect (org-contacts-format-email contact-name email))))
 448          (completion-list (org-contacts-all-completions-prefix
 449                            string
 450                            (org-uniquify completion-list))))
 451     (when completion-list
 452       (list start end
 453             (org-contacts-make-collection-prefix completion-list)))))
 454
 455 (defun org-contacts-message-complete-function (&optional start)
 456   "Function used in `completion-at-point-functions' in `message-mode'."
 457   ;; Avoid to complete in `post-command-hook'.
 458   (when completion-in-region-mode
 459     (remove-hook 'post-command-hook #'completion-in-region--postch))
 460   (let ((mail-abbrev-mode-regexp
 461          "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
 462     (when (mail-abbrev-in-expansion-header-p)
 463       (lexical-let*
 464           ((end (point))
 465            (start (or start
 466                       (save-excursion
 467                         (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 468                         (goto-char (match-end 0))
 469                         (point))))
 470            (string (buffer-substring start end)))
 471         (or (org-contacts-complete-group start end string)
 472             (org-contacts-complete-name start end string))))))
 473
 474 (defun org-contacts-gnus-get-name-email ()
 475   "Get name and email address from Gnus message."
 476   (if (gnus-alive-p)
 477       (gnus-with-article-headers
 478         (mail-extract-address-components
 479          (or (mail-fetch-field "From") "")))))
 480
 481 (defun org-contacts-gnus-article-from-get-marker ()
 482   "Return a marker for a contact based on From."
 483   (let* ((address (org-contacts-gnus-get-name-email))
 484          (name (car address))
 485          (email (cadr address)))
 486     (cadar (or (org-contacts-filter
 487                 nil
 488                 (concat org-contacts-email-property "={\\b" (regexp-quote email) "\\b}"))
 489                (when name
 490                  (org-contacts-filter
 491                   (concat "^" name "$")))))))
 492
 493 (defun org-contacts-gnus-article-from-goto ()
 494   "Go to contact in the From address of current Gnus message."
 495   (interactive)
 496   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 497     (when marker
 498       (switch-to-buffer-other-window (marker-buffer marker))
 499       (goto-char marker)
 500       (when (eq major-mode 'org-mode)
 501         (org-show-context 'agenda)
 502         (save-excursion
 503           (and (outline-next-heading)
 504                ;; show the next heading
 505                (org-flag-heading nil)))))))
 506
 507 (org-no-warnings (defvar date)) ;; unprefixed, from calendar.el
 508 (defun org-contacts-anniversaries (&optional field format)
 509   "Compute FIELD anniversary for each contact, returning FORMAT.
 510 Default FIELD value is \"BIRTHDAY\".
 511
 512 Format is a string matching the following format specification:
 513
 514   %h - Heading name
 515   %l - Link to the heading
 516   %y - Number of year
 517   %Y - Number of year (ordinal)"
 518   (let ((calendar-date-style 'american)
 519         (entry ""))
 520     (unless format (setq format org-contacts-birthday-format))
 521     (loop for contact in (org-contacts-filter)
 522           for anniv = (let ((anniv (cdr (assoc-string
 523                                          (or field org-contacts-birthday-property)
 524                                          (caddr contact)))))
 525                         (when anniv
 526                           (calendar-gregorian-from-absolute
 527                            (org-time-string-to-absolute anniv))))
 528           ;; Use `diary-anniversary' to compute anniversary.
 529           if (and anniv (apply 'diary-anniversary anniv))
 530           collect (format-spec format
 531                                `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
 532                                  (?h . ,(car contact))
 533                                  (?y . ,(- (calendar-extract-year date)
 534                                            (calendar-extract-year anniv)))
 535                                  (?Y . ,(let ((years (- (calendar-extract-year date)
 536                                                         (calendar-extract-year anniv))))
 537                                           (format "%d%s" years (diary-ordinal-suffix years)))))))))
 538
 539 (defun org-completing-read-date (prompt collection
 540                                         &optional predicate require-match initial-input
 541                                         hist def inherit-input-method)
 542   "Like `completing-read' but reads a date.
 543 Only PROMPT and DEF are really used."
 544   (org-read-date nil nil nil prompt nil def))
 545
 546 (add-to-list 'org-property-set-functions-alist
 547              `(,org-contacts-birthday-property . org-completing-read-date))
 548
 549 (defun org-contacts-template-name (&optional return-value)
 550   "Try to return the contact name for a template.
 551 If not found return RETURN-VALUE or something that would ask the user."
 552   (or (car (org-contacts-gnus-get-name-email))
 553       return-value
 554       "%^{Name}"))
 555
 556 (defun org-contacts-template-email (&optional return-value)
 557   "Try to return the contact email for a template.
 558 If not found return RETURN-VALUE or something that would ask the user."
 559   (or (cadr (org-contacts-gnus-get-name-email))
 560       return-value
 561       (concat "%^{" org-contacts-email-property "}p")))
 562
 563 (defun org-contacts-gnus-store-last-mail ()
 564   "Store a link between mails and contacts.
 565
 566 This function should be called from `gnus-article-prepare-hook'."
 567   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 568     (when marker
 569       (with-current-buffer (marker-buffer marker)
 570         (save-excursion
 571           (goto-char marker)
 572           (let* ((org-email-link-description-format (or org-contacts-email-link-description-format
 573                                                         org-email-link-description-format))
 574                  (link (gnus-with-article-buffer (org-store-link nil))))
 575             (org-set-property org-contacts-last-read-mail-property link)))))))
 576
 577 (defun org-contacts-icon-as-string ()
 578   "Return the contact icon as a string."
 579   (let ((image (org-contacts-get-icon)))
 580     (concat
 581      (propertize "-" 'display
 582                  (append
 583                   (if image
 584                       image
 585                     `'(space :width (,org-contacts-icon-size)))
 586                   '(:ascent center)))
 587      " ")))
 588
 589 ;;;###autoload
 590 (defun org-contacts (name)
 591   "Create agenda view for contacts matching NAME."
 592   (interactive (list (read-string "Name: ")))
 593   (let ((org-agenda-files (org-contacts-files))
 594         (org-agenda-skip-function
 595          (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
 596         (org-agenda-prefix-format (propertize
 597                                    "%(org-contacts-icon-as-string)% s%(org-contacts-irc-number-of-unread-messages) "
 598                                    'keymap org-contacts-keymap))
 599         (org-agenda-overriding-header
 600          (or org-agenda-overriding-header
 601              (concat "List of contacts matching `" name "':"))))
 602     (setq org-agenda-skip-regexp name)
 603     (org-tags-view nil org-contacts-matcher)
 604     (with-current-buffer org-agenda-buffer-name
 605       (setq org-agenda-redo-command
 606             (list 'org-contacts name)))))
 607
 608 (defun org-contacts-completing-read (prompt
 609                                      &optional predicate
 610                                      initial-input hist def inherit-input-method)
 611   "Call `completing-read' with contacts name as collection."
 612   (org-completing-read
 613    prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method))
 614
 615 (defun org-contacts-format-name (name)
 616   "Trim any local formatting to get a bare NAME."
 617   ;; Remove radio targets characters
 618   (replace-regexp-in-string org-radio-target-regexp "\\1" name))
 619
 620 (defun org-contacts-format-email (name email)
 621   "Format an EMAIL address corresponding to NAME."
 622   (unless email
 623     (error "`email' cannot be nul"))
 624   (if name
 625       (concat (org-contacts-format-name name) " <" email ">")
 626     email))
 627
 628 (defun org-contacts-check-mail-address (mail)
 629   "Add MAIL address to contact at point if it does not have it."
 630   (let ((mails (org-entry-get (point) org-contacts-email-property)))
 631     (unless (member mail (split-string mails))
 632       (when (yes-or-no-p
 633              (format "Do you want to add this address to %s?" (org-get-heading t)))
 634         (org-set-property org-contacts-email-property (concat mails " " mail))))))
 635
 636 (defun org-contacts-gnus-check-mail-address ()
 637   "Check that contact has the current address recorded.
 638 This function should be called from `gnus-article-prepare-hook'."
 639   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 640     (when marker
 641       (org-with-point-at marker
 642         (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))
 643
 644 (defun org-contacts-gnus-insinuate ()
 645   "Add some hooks for Gnus user.
 646 This adds `org-contacts-gnus-check-mail-address' and
 647 `org-contacts-gnus-store-last-mail' to
 648 `gnus-article-prepare-hook'.  It also adds a binding on `;' in
 649 `gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
 650   (require 'gnus)
 651   (require 'gnus-art)
 652   (define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto)
 653   (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address)
 654   (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail))
 655
 656 (when (and org-contacts-enable-completion
 657            (boundp 'completion-at-point-functions))
 658   (add-hook 'message-mode-hook
 659             (lambda ()
 660               (add-to-list 'completion-at-point-functions
 661                            'org-contacts-message-complete-function))))
 662
 663 (defun org-contacts-wl-get-from-header-content ()
 664   "Retrieve the content of the `From' header of an email.
 665 Works from wl-summary-mode and mime-view-mode - that is while viewing email.
 666 Depends on Wanderlust been loaded."
 667   (with-current-buffer (org-capture-get :original-buffer)
 668     (cond
 669      ((eq major-mode 'wl-summary-mode) (when (and (boundp 'wl-summary-buffer-elmo-folder)
 670                                                   wl-summary-buffer-elmo-folder)
 671                                          (elmo-message-field
 672                                           wl-summary-buffer-elmo-folder
 673                                           (wl-summary-message-number)
 674                                           'from)))
 675      ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
 676       (prog1
 677           (std11-fetch-field "From")
 678         (widen))))))
 679
 680 (defun org-contacts-wl-get-name-email ()
 681   "Get name and email address from Wanderlust email.
 682 See `org-contacts-wl-get-from-header-content' for limitations."
 683   (let ((from (org-contacts-wl-get-from-header-content)))
 684     (when from
 685       (list (wl-address-header-extract-realname from)
 686             (wl-address-header-extract-address from)))))
 687
 688 (defun org-contacts-template-wl-name (&optional return-value)
 689   "Try to return the contact name for a template from wl.
 690 If not found, return RETURN-VALUE or something that would ask the
 691 user."
 692   (or (car (org-contacts-wl-get-name-email))
 693       return-value
 694       "%^{Name}"))
 695
 696 (defun org-contacts-template-wl-email (&optional return-value)
 697   "Try to return the contact email for a template from Wanderlust.
 698 If not found return RETURN-VALUE or something that would ask the user."
 699   (or (cadr (org-contacts-wl-get-name-email))
 700       return-value
 701       (concat "%^{" org-contacts-email-property "}p")))
 702
 703 (defun org-contacts-view-send-email (&optional ask)
 704   "Send email to the contact at point.
 705 If ASK is set, ask for the email address even if there's only one
 706 address."
 707   (interactive "P")
 708   (let ((marker (org-get-at-bol 'org-hd-marker)))
 709     (org-with-point-at marker
 710       (let ((emails (org-entry-get (point) org-contacts-email-property)))
 711         (if emails
 712             (let ((email-list (split-string emails)))
 713               (if (and (= (length email-list) 1) (not ask))
 714                   (compose-mail (org-contacts-format-email
 715                                  (org-get-heading t) emails))
 716                 (let ((email (completing-read "Send mail to which address: " email-list)))
 717                   (org-contacts-check-mail-address email)
 718                   (compose-mail (org-contacts-format-email (org-get-heading t) email)))))
 719           (error (format "This contact has no mail address set (no %s property)."
 720                          org-contacts-email-property)))))))
 721
 722 (defun org-contacts-get-icon (&optional pom)
 723   "Get icon for contact at POM."
 724   (setq pom (or pom (point)))
 725   (catch 'icon
 726     ;; Use `org-contacts-icon-property'
 727     (let ((image-data (org-entry-get pom org-contacts-icon-property)))
 728       (when image-data
 729         (throw 'icon
 730                (if (fboundp 'gnus-rescale-image)
 731                    (gnus-rescale-image (create-image image-data)
 732                                        (cons org-contacts-icon-size org-contacts-icon-size))
 733                  (create-image image-data)))))
 734     ;; Next, try Gravatar
 735     (when org-contacts-icon-use-gravatar
 736       (let* ((gravatar-size org-contacts-icon-size)
 737              (email-list (org-entry-get pom org-contacts-email-property))
 738              (gravatar
 739               (when email-list
 740                 (loop for email in (split-string email-list)
 741                       for gravatar = (gravatar-retrieve-synchronously email)
 742                       if (and gravatar
 743                               (not (eq gravatar 'error)))
 744                       return gravatar))))
 745         (when gravatar (throw 'icon gravatar))))))
 746
 747 (defun org-contacts-irc-buffer (&optional pom)
 748   "Get the IRC buffer associated with the entry at POM."
 749   (setq pom (or pom (point)))
 750   (let ((nick (org-entry-get pom org-contacts-nickname-property)))
 751     (when nick
 752       (let ((buffer (get-buffer nick)))
 753         (when buffer
 754           (with-current-buffer buffer
 755             (when (eq major-mode 'erc-mode)
 756               buffer)))))))
 757
 758 (defun org-contacts-irc-number-of-unread-messages (&optional pom)
 759   "Return the number of unread messages for contact at POM."
 760   (when (boundp 'erc-modified-channels-alist)
 761     (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist))))
 762       (if number
 763           (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number)
 764         (make-string 21 ? )))))
 765
 766 (defun org-contacts-view-switch-to-irc-buffer ()
 767   "Switch to the IRC buffer of the current contact if it has one."
 768   (interactive)
 769   (let ((marker (org-get-at-bol 'org-hd-marker)))
 770     (org-with-point-at marker
 771       (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
 772
 773 (defun org-contacts-completing-read-nickname (prompt collection
 774                                                      &optional predicate require-match initial-input
 775                                                      hist def inherit-input-method)
 776   "Like `completing-read' but reads a nickname."
 777   (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match
 778                        initial-input hist def inherit-input-method))
 779
 780 (defun erc-nicknames-list ()
 781   "Return all nicknames of all ERC buffers."
 782   (if (fboundp 'erc-buffer-list)
 783       (loop for buffer in (erc-buffer-list)
 784             nconc (with-current-buffer buffer
 785                     (loop for user-entry in (mapcar 'car (erc-get-channel-user-list))
 786                           collect (elt user-entry 1))))))
 787
 788 (add-to-list 'org-property-set-functions-alist
 789              `(,org-contacts-nickname-property . org-contacts-completing-read-nickname))
 790
 791 (defun org-contacts-vcard-escape (str)
 792   "Escape ; , and \n in STR for the VCard format."
 793   ;; Thanks to this library for the regexp:
 794   ;; http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el
 795   (when str
 796     (replace-regexp-in-string
 797      "\n" "\\\\n"
 798      (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))
 799
 800 (defun org-contacts-vcard-encode-name (name)
 801   "Try to encode NAME as VCard's N property.
 802 The N property expects
 803
 804   FamilyName;GivenName;AdditionalNames;Prefix;Postfix.
 805
 806 Org-contacts does not specify how to encode the name.  So we try
 807 to do our best."
 808   (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;"))
 809
 810 (defun org-contacts-vcard-format (contact)
 811   "Formats CONTACT in VCard 3.0 format."
 812   (let* ((properties (caddr contact))
 813          (name (org-contacts-vcard-escape (car contact)))
 814          (n (org-contacts-vcard-encode-name name))
 815          (email (org-contacts-vcard-escape (cdr (assoc-string org-contacts-email-property properties))))
 816          (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties))))
 817          (addr (cdr (assoc-string org-contacts-address-property properties)))
 818          (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties))))
 819          (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name)))
 820     (concat head
 821             (when email (format "EMAIL:%s\n" email))
 822             (when addr
 823               (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
 824             (when bday
 825               (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday))))
 826                 (format "BDAY:%04d-%02d-%02d\n"
 827                         (calendar-extract-year cal-bday)
 828                         (calendar-extract-month cal-bday)
 829                         (calendar-extract-day cal-bday))))
 830             (when nick (format "NICKNAME:%s\n" nick))
 831             "END:VCARD\n\n")))
 832
 833 (defun org-contacts-export-as-vcard (&optional name file to-buffer)
 834   "Export all contacts matching NAME as VCard 3.0.
 835 If TO-BUFFER is nil, the content is written to FILE or
 836 `org-contacts-vcard-file'.  If TO-BUFFER is non-nil, the buffer
 837 is created and the VCard is written into that buffer."
 838   (interactive) ; TODO ask for name?
 839   (let* ((filename (or file org-contacts-vcard-file))
 840          (buffer (if to-buffer
 841                      (get-buffer-create to-buffer)
 842                    (find-file-noselect filename))))
 843
 844     (message "Exporting...")
 845
 846     (set-buffer buffer)
 847     (let ((inhibit-read-only t)) (erase-buffer))
 848     (fundamental-mode)
 849     (org-install-letbind)
 850
 851     (when (fboundp 'set-buffer-file-coding-system)
 852       (set-buffer-file-coding-system coding-system-for-write))
 853
 854     (loop for contact in (org-contacts-filter name)
 855           do (insert (org-contacts-vcard-format contact)))
 856
 857     (if to-buffer
 858         (current-buffer)
 859       (progn (save-buffer) (kill-buffer)))))
 860
 861 (defun org-contacts-show-map (&optional name)
 862   "Show contacts on a map.
 863 Requires google-maps-el."
 864   (interactive)
 865   (unless (fboundp 'google-maps-static-show)
 866     (error "`org-contacts-show-map' requires `google-maps-el'"))
 867   (google-maps-static-show
 868    :markers
 869    (loop
 870     for contact in (org-contacts-filter name)
 871     for addr = (cdr (assoc-string org-contacts-address-property (caddr contact)))
 872     if addr
 873     collect (cons (list addr) (list :label (string-to-char (car contact)))))))
 874
 875 (provide 'org-contacts)
 876
 877 (provide 'org-contacts)
 878
 879 ;;; org-contacts.el ends here