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