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