org-mode/contrib/lisp/org-contacts.el

;;; org-contacts.el --- Contacts management

;; Copyright (C) 2010-2012 Julien Danjou <julien@danjou.info>

;; Author: Julien Danjou <julien@danjou.info>
;; Keywords: outlines, hypermedia, calendar
;;
;; This file is NOT part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:

;; This file contains the code for managing your contacts into Org-mode.

;; To enter new contacts, you can use `org-capture' and a template just like
;; this:

;;         ("c" "Contacts" entry (file "~/Org/contacts.org")
;;          "* %(org-contacts-template-name)
;; :PROPERTIES:
;; :EMAIL: %(org-contacts-template-email)
;; :END:")))
;;
;;; Code:

(eval-when-compile
  (require 'cl))

(eval-and-compile
  (require 'org))
(require 'gnus-util)
(require 'org-agenda)

(defgroup org-contacts nil
  "Options about contacts management."
  :group 'org)

(defcustom org-contacts-files nil
  "List of Org files to use as contacts source.
When set to nil, all your Org files will be used."
  :type '(repeat file)
  :group 'org-contacts)

(defcustom org-contacts-email-property "EMAIL"
  "Name of the property for contact email address."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-address-property "ADDRESS"
  "Name of the property for contact address."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-birthday-property "BIRTHDAY"
  "Name of the property for contact birthday date."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-birthday-format "Birthday: %l (%Y)"
  "Format of the anniversary agenda entry.
The following replacements are available:

  %h - Heading name
  %l - Link to the heading
  %y - Number of year
  %Y - Number of year (ordinal)"
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-last-read-mail-property "LAST_READ_MAIL"
  "Name of the property for contact last read email link storage."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-icon-property "ICON"
  "Name of the property for contact icon."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-nickname-property "NICKNAME"
  "Name of the property for IRC nickname match."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-icon-size 32
  "Size of the contacts icons."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-icon-use-gravatar (fboundp 'gravatar-retrieve)
  "Whether use Gravatar to fetch contact icons."
  :type 'boolean
  :group 'org-contacts)

(defcustom org-contacts-completion-ignore-case t
  "Ignore case when completing contacts."
  :type 'boolean
  :group 'org-contacts)

(defcustom org-contacts-group-prefix "+"
  "Group prefix."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-matcher (concat org-contacts-email-property "<>\"\"")
  "Matching rule for finding heading that are contacts.
This can be a tag name, or a property check."
  :type 'string
  :group 'org-contacts)

(defcustom org-contacts-email-link-description-format "%s (%d)"
  "Format used to store links to email.
This overrides `org-email-link-description-format' if set."
  :group 'org-contacts
  :type 'string)

(defcustom org-contacts-vcard-file "contacts.vcf"
  "Default file for vcard export."
  :group 'org-contacts
  :type 'file)

(defvar org-contacts-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map "M" 'org-contacts-view-send-email)
    (define-key map "i" 'org-contacts-view-switch-to-irc-buffer)
    map)
  "The keymap used in `org-contacts' result list.")

(defun org-contacts-files ()
  "Return list of Org files to use for contact management."
  (or org-contacts-files (org-agenda-files t 'ifmode)))

(defun org-contacts-filter (&optional name-match tags-match)
  "Search for a contact maching NAME-MATCH and TAGS-MATCH.
If both match values are nil, return all contacts."
  (let* (todo-only
	 (tags-matcher
	  (if tags-match
	      (cdr (org-make-tags-matcher tags-match))
	    t))
	 (name-matcher
	  (if name-match
	      '(org-string-match-p name-match (org-get-heading t))
	    t))
	 (contacts-matcher
	  (cdr (org-make-tags-matcher org-contacts-matcher)))
	 markers result)
    (dolist (file (org-contacts-files))
      (org-check-agenda-file file)
      (with-current-buffer (org-get-agenda-file-buffer file)
        (unless (eq major-mode 'org-mode)
          (error "File %s is no in `org-mode'" file))
        (org-scan-tags
         '(add-to-list 'markers (set-marker (make-marker) (point)))
         `(and ,contacts-matcher ,tags-matcher ,name-matcher)
	 todo-only)))
    (dolist (marker markers result)
      (org-with-point-at marker
        (add-to-list 'result
                     (list (org-get-heading t) marker (org-entry-properties marker 'all)))))))

(when (not (fboundp 'completion-table-case-fold))
  ;; That function is new in Emacs 24...
  (defun completion-table-case-fold (table &optional dont-fold)
    (lambda (string pred action)
      (let ((completion-ignore-case (not dont-fold)))
	(complete-with-action action table string pred)))))

(defun org-contacts-complete-name (&optional start)
  "Complete text at START with a user name and email."
  (let* ((end (point))
         (start (or start
                    (save-excursion
                      (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
                      (goto-char (match-end 0))
                      (point))))
         (orig (buffer-substring start end))
         (completion-ignore-case org-contacts-completion-ignore-case)
         (group-completion-p (org-string-match-p
			      (concat "^" org-contacts-group-prefix) orig))
         (completion-list
          (if group-completion-p
              (mapcar (lambda (group) (propertize (concat org-contacts-group-prefix group)
						  'org-contacts-group group))
                      (org-uniquify
                       (loop for contact in (org-contacts-filter)
                             with group-list
                             nconc (org-split-string
                                    (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
            (loop for contact in (org-contacts-filter)
                  ;; The contact name is always the car of the assoc-list
                  ;; returned by `org-contacts-filter'.
                  for contact-name = (car contact)
                  ;; Build the list of the user email addresses.
                  for email-list = (split-string (or
                                                  (cdr (assoc-string org-contacts-email-property
								     (caddr contact))) ""))
                  ;; If the user has email addresses…
                  if email-list
                  ;; … append a list of USER <EMAIL>.
                  nconc (loop for email in email-list
                              collect (org-contacts-format-email contact-name email)))))
         (completion-list (all-completions orig completion-list)))
    ;; If we are completing a group, and that's the only group, just return
    ;; the real result.
    (when (and group-completion-p
               (= (length completion-list) 1))
      (setq completion-list
            (list (concat
		   (car completion-list) ";: "
		   (mapconcat 'identity
			      (loop for contact in (org-contacts-filter
						    nil
						    (get-text-property 0 'org-contacts-group
								       (car completion-list)))
				    ;; The contact name is always the car of the assoc-list
				    ;; returned by `org-contacts-filter'.
				    for contact-name = (car contact)
				    ;; Grab the first email of the contact
				    for email = (car (split-string
						      (or
						       (cdr (assoc-string org-contacts-email-property
									  (caddr contact)))
						       "")))
				    ;; If the user has an email address, append USER <EMAIL>.
				    if email collect (org-contacts-format-email contact-name email))
			      ", ")))))
    (list start end
	  (completion-table-case-fold completion-list
				      (not org-contacts-completion-ignore-case)))))

(defun org-contacts-message-complete-function ()
  "Function used in `completion-at-point-functions' in `message-mode'."
  (let ((mail-abbrev-mode-regexp
         "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
    (when (mail-abbrev-in-expansion-header-p)
      (org-contacts-complete-name))))

(defun org-contacts-gnus-get-name-email ()
  "Get name and email address from Gnus message."
  (if (gnus-alive-p)
      (gnus-with-article-headers
        (mail-extract-address-components
         (or (mail-fetch-field "From") "")))))

(defun org-contacts-gnus-article-from-get-marker ()
  "Return a marker for a contact based on From."
  (let* ((address (org-contacts-gnus-get-name-email))
         (name (car address))
         (email (cadr address)))
    (cadar (or (org-contacts-filter
                nil
                (concat org-contacts-email-property "={\\b" (regexp-quote email) "\\b}"))
               (when name
                 (org-contacts-filter
                  (concat "^" name "$")))))))

(defun org-contacts-gnus-article-from-goto ()
  "Go to contact in the From address of current Gnus message."
  (interactive)
  (let ((marker (org-contacts-gnus-article-from-get-marker)))
    (when marker
      (switch-to-buffer-other-window (marker-buffer marker))
      (goto-char marker)
      (when (eq major-mode 'org-mode)
        (org-show-context 'agenda)
        (save-excursion
          (and (outline-next-heading)
               ;; show the next heading
               (org-flag-heading nil)))))))

(defun org-contacts-anniversaries (&optional field format)
  "Compute FIELD anniversary for each contact, returning FORMAT.
Default FIELD value is \"BIRTHDAY\".

Format is a string matching the following format specification:

  %h - Heading name
  %l - Link to the heading
  %y - Number of year
  %Y - Number of year (ordinal)"
  (let ((calendar-date-style 'american)
        (entry ""))
    (unless format (setq format org-contacts-birthday-format))
    (loop for contact in (org-contacts-filter)
          for anniv = (let ((anniv (cdr (assoc-string
                                         (or field org-contacts-birthday-property)
                                         (caddr contact)))))
                        (when anniv
                          (calendar-gregorian-from-absolute
                           (org-time-string-to-absolute anniv))))
          ;; Use `diary-anniversary' to compute anniversary.
          if (and anniv (apply 'diary-anniversary anniv))
          collect (format-spec format
                               `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
                                 (?h . ,(car contact))
                                 (?y . ,(- (calendar-extract-year date)
                                           (calendar-extract-year anniv)))
                                 (?Y . ,(let ((years (- (calendar-extract-year date)
                                                        (calendar-extract-year anniv))))
                                          (format "%d%s" years (diary-ordinal-suffix years)))))))))

(defun org-completing-read-date (prompt collection
                                        &optional predicate require-match initial-input
                                        hist def inherit-input-method)
  "Like `completing-read' but reads a date.
Only PROMPT and DEF are really used."
  (org-read-date nil nil nil prompt nil def))

(add-to-list 'org-property-set-functions-alist
             `(,org-contacts-birthday-property . org-completing-read-date))

(defun org-contacts-template-name (&optional return-value)
  "Try to return the contact name for a template.
If not found return RETURN-VALUE or something that would ask the user."
  (or (car (org-contacts-gnus-get-name-email))
      return-value
      "%^{Name}"))

(defun org-contacts-template-email (&optional return-value)
  "Try to return the contact email for a template.
If not found return RETURN-VALUE or something that would ask the user."
  (or (cadr (org-contacts-gnus-get-name-email))
      return-value
      (concat "%^{" org-contacts-email-property "}p")))

(defun org-contacts-gnus-store-last-mail ()
  "Store a link between mails and contacts.

This function should be called from `gnus-article-prepare-hook'."
  (let ((marker (org-contacts-gnus-article-from-get-marker)))
    (when marker
      (with-current-buffer (marker-buffer marker)
        (save-excursion
          (goto-char marker)
          (let* ((org-email-link-description-format (or org-contacts-email-link-description-format
                                                        org-email-link-description-format))
                 (link (gnus-with-article-buffer (org-store-link nil))))
            (org-set-property org-contacts-last-read-mail-property link)))))))

(defun org-contacts-icon-as-string ()
  (let ((image (org-contacts-get-icon)))
    (concat
     (propertize "-" 'display
                 (append
                  (if image
                      image
                    `'(space :width (,org-contacts-icon-size)))
                  '(:ascent center)))
     " ")))

;;;###autoload
(defun org-contacts (name)
  "Create agenda view for contacts matching NAME."
  (interactive (list (read-string "Name: ")))
  (let ((org-agenda-files (org-contacts-files))
        (org-agenda-skip-function
         (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
        (org-agenda-format (propertize
                            "%(org-contacts-icon-as-string)% p% s%(org-contacts-irc-number-of-unread-messages)%+T"
                            'keymap org-contacts-keymap))
        (org-agenda-overriding-header
         (or org-agenda-overriding-header
             (concat "List of contacts matching `" name "':"))))
    (setq org-agenda-skip-regexp name)
    (org-tags-view nil org-contacts-matcher)
    (with-current-buffer org-agenda-buffer-name
      (setq org-agenda-redo-command
            (list 'org-contacts name)))))

(defun org-contacts-completing-read (prompt
                                     &optional predicate
                                     initial-input hist def inherit-input-method)
  "Call `completing-read' with contacts name as collection."
  (org-completing-read
   prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method))

(defun org-contacts-format-email (name email)
  "Format a mail address."
  (unless email
    (error "`email' cannot be nul"))
  (if name
      (concat name " <" email ">")
    email))

(defun org-contacts-check-mail-address (mail)
  "Add MAIL address to contact at point if it does not have it."
  (let ((mails (org-entry-get (point) org-contacts-email-property)))
    (unless (member mail (split-string mails))
      (when (yes-or-no-p
             (format "Do you want to add this address to %s?" (org-get-heading t)))
        (org-set-property org-contacts-email-property (concat mails " " mail))))))

(defun org-contacts-gnus-check-mail-address ()
  "Check that contact has the current address recorded.
This function should be called from `gnus-article-prepare-hook'."
  (let ((marker (org-contacts-gnus-article-from-get-marker)))
    (when marker
      (org-with-point-at marker
        (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))

(defun org-contacts-gnus-insinuate ()
  "Add some hooks for Gnus user.
This adds `org-contacts-gnus-check-mail-address' and
`org-contacts-gnus-store-last-mail' to
`gnus-article-prepare-hook'. It also adds a binding on `;' in
`gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
  (require 'gnus)
  (require 'gnus-art)
  (define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto)
  (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address)
  (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail))

(when (boundp 'completion-at-point-functions)
  (add-hook 'message-mode-hook
	    (lambda ()
	      (add-to-list 'completion-at-point-functions
			   'org-contacts-message-complete-function))))

(defun org-contacts-wl-get-from-header-content ()
  "Retrieve the content of the `From' header of an email.
Works from wl-summary-mode and mime-view-mode - that is while viewing email.
Depends on Wanderlust been loaded."
  (with-current-buffer (org-capture-get :original-buffer)
    (cond
     ((eq major-mode 'wl-summary-mode) (when wl-summary-buffer-elmo-folder
                                         (elmo-message-field
                                          wl-summary-buffer-elmo-folder
                                          (wl-summary-message-number)
                                          'from)))
     ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
      (prog1
	  (std11-fetch-field "From")
	(widen))))))

(defun org-contacts-wl-get-name-email ()
  "Get name and email address from Wanderlust email.
See `org-contacts-wl-get-from-header-content' for limitations."
  (let ((from (org-contacts-wl-get-from-header-content)))
    (when from
      (list (wl-address-header-extract-realname from)
	    (wl-address-header-extract-address from)))))

(defun org-contacts-template-wl-name (&optional return-value)
  "Try to return the contact name for a template from wl.
If not found, return RETURN-VALUE or something that would ask the
user."
  (or (car (org-contacts-wl-get-name-email))
      return-value
      "%^{Name}"))

(defun org-contacts-template-wl-email (&optional return-value)
  "Try to return the contact email for a template from Wanderlust.
If not found return RETURN-VALUE or something that would ask the user."
  (or (cadr (org-contacts-wl-get-name-email))
      return-value
      (concat "%^{" org-contacts-email-property "}p")))

(defun org-contacts-view-send-email (&optional ask)
  "Send email to the contact at point.
If ASK is set, ask for the email address even if there's only one
address."
  (interactive "P")
  (let ((marker (org-get-at-bol 'org-hd-marker)))
    (org-with-point-at marker
      (let ((emails (org-entry-get (point) org-contacts-email-property)))
        (if emails
            (let ((email-list (split-string emails)))
              (if (and (= (length email-list) 1) (not ask))
                  (compose-mail (org-contacts-format-email
                                 (org-get-heading t) emails))
                (let ((email (completing-read "Send mail to which address: " email-list)))
                  (org-contacts-check-mail-address email)
                  (compose-mail (org-contacts-format-email (org-get-heading t) email)))))
          (error (format "This contact has no mail address set (no %s property)."
                         org-contacts-email-property)))))))

(defun org-contacts-get-icon (&optional pom)
  "Get icon for contact at POM."
  (setq pom (or pom (point)))
  (catch 'icon
    ;; Use `org-contacts-icon-property'
    (let ((image-data (org-entry-get pom org-contacts-icon-property)))
      (when image-data
        (throw 'icon
               (if (fboundp 'gnus-rescale-image)
                   (gnus-rescale-image (create-image image-data)
                                       (cons org-contacts-icon-size org-contacts-icon-size))
                 (create-image image-data)))))
    ;; Next, try Gravatar
    (when org-contacts-icon-use-gravatar
      (let* ((gravatar-size org-contacts-icon-size)
             (email-list (org-entry-get pom org-contacts-email-property))
             (gravatar
              (when email-list
                (loop for email in (split-string email-list)
                      for gravatar = (gravatar-retrieve-synchronously email)
                      if (and gravatar
                              (not (eq gravatar 'error)))
                      return gravatar))))
        (when gravatar (throw 'icon gravatar))))))

(defun org-contacts-irc-buffer (&optional pom)
  "Get the IRC buffer associated with the entry at POM."
  (setq pom (or pom (point)))
  (let ((nick (org-entry-get pom org-contacts-nickname-property)))
    (when nick
      (let ((buffer (get-buffer nick)))
        (when buffer
          (with-current-buffer buffer
            (when (eq major-mode 'erc-mode)
              buffer)))))))

(defun org-contacts-irc-number-of-unread-messages (&optional pom)
  "Return the number of unread messages for contact at POM."
  (when (boundp 'erc-modified-channels-alist)
    (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist))))
      (if number
          (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number)
        (make-string 21 ? )))))

(defun org-contacts-view-switch-to-irc-buffer ()
  "Switch to the IRC buffer of the current contact if it has one."
  (interactive)
  (let ((marker (org-get-at-bol 'org-hd-marker)))
    (org-with-point-at marker
      (switch-to-buffer-other-window (org-contacts-irc-buffer)))))

(defun org-contacts-completing-read-nickname (prompt collection
                                                     &optional predicate require-match initial-input
                                                     hist def inherit-input-method)
  "Like `completing-read' but reads a nickname."
  (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match
                       initial-input hist def inherit-input-method))

(defun erc-nicknames-list ()
  "Return all nicknames of all ERC buffers."
  (if (fboundp 'erc-buffer-list)
      (loop for buffer in (erc-buffer-list)
            nconc (with-current-buffer buffer
                    (loop for user-entry in (mapcar 'car (erc-get-channel-user-list))
                          collect (elt user-entry 1))))))

(add-to-list 'org-property-set-functions-alist
             `(,org-contacts-nickname-property . org-contacts-completing-read-nickname))

(defun org-contacts-vcard-escape (str)
  "Escape ; , and \n in STR for the VCard format."
  ;; Thanks to this library for the regexp:
  ;; http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el
  (when str
    (replace-regexp-in-string
     "\n" "\\\\n"
     (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))

(defun org-contacts-vcard-encode-name (name)
  "Try to encode NAME as VCard's N property.
The N property expects

  FamilyName;GivenName;AdditionalNames;Prefix;Postfix.

Org-contacts does not specify how to encode the name.  So we try
to do our best."
  (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;"))

(defun org-contacts-vcard-format (contact)
  "Formats CONTACT in VCard 3.0 format."
  (let* ((properties (caddr contact))
	 (name (org-contacts-vcard-escape (car contact)))
	 (n (org-contacts-vcard-encode-name name))
	 (email (org-contacts-vcard-escape (cdr (assoc-string org-contacts-email-property properties))))
	 (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties))))
	 (addr (cdr (assoc-string org-contacts-address-property properties)))
	 (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties))))
	 (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name)))
    (concat head
	    (when email (format "EMAIL:%s\n" email))
	    (when addr
	      (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
	    (when bday
	      (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday))))
		(format "BDAY:%04d-%02d-%02d\n"
			(calendar-extract-year cal-bday)
			(calendar-extract-month cal-bday)
			(calendar-extract-day cal-bday))))
	    (when nick (format "NICKNAME:%s\n" nick))
	    "END:VCARD\n\n")))

(defun org-contacts-export-as-vcard (&optional name file to-buffer)
  "Export all contacts matching NAME as VCard 3.0.
If TO-BUFFER is nil, the content is written to FILE or
`org-contacts-vcard-file'.  If TO-BUFFER is non-nil, the buffer
is created and the VCard is written into that buffer."
  (interactive) ; TODO ask for name?
  (let* ((filename (or file org-contacts-vcard-file))
	 (buffer (if to-buffer
		     (get-buffer-create to-buffer)
		   (find-file-noselect filename))))

    (message "Exporting...")

    (set-buffer buffer)
    (let ((inhibit-read-only t)) (erase-buffer))
    (fundamental-mode)
    (org-install-letbind)

    (when (fboundp 'set-buffer-file-coding-system)
      (set-buffer-file-coding-system coding-system-for-write))

    (loop for contact in (org-contacts-filter name)
	  do (insert (org-contacts-vcard-format contact)))

    (if to-buffer
	(current-buffer)
      (progn (save-buffer) (kill-buffer)))))

(defun org-contacts-show-map (&optional name)
  "Show contacts on a map.
Requires google-maps-el."
  (interactive)
  (unless (fboundp 'google-maps-static-show)
    (error "`org-contacts-show-map' requires `google-maps-el'"))
  (google-maps-static-show
   :markers
   (loop
    for contact in (org-contacts-filter name)
    for addr = (cdr (assoc-string org-contacts-address-property (caddr contact)))
    if addr
    collect (cons (list addr) (list :label (string-to-char (car contact)))))))

(provide 'org-contacts)