[elpa] externals/org-contacts ad99d80ad3 001/154: org-contacts: import

[ELPA Syncer]

branch: externals/org-contacts
commit ad99d80ad37b085745b268261f03e1144a3fb460
Author: Julien Danjou <julien@danjou.info>
Commit: Julien Danjou <julien@danjou.info>

    org-contacts: import
    
    Signed-off-by: Julien Danjou <julien@danjou.info>
---
 org-contacts.el | 477 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 477 insertions(+)

diff --git a/org-contacts.el b/org-contacts.el
new file mode 100644
index 0000000000..86b1741a6f
--- /dev/null
+++ b/org-contacts.el
@@ -0,0 +1,477 @@
+;;; org-contacts.el --- Contacts management
+
+;; Copyright (C) 2010, 2011 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-and-compile
+  (require 'org)
+  (require 'gnus)
+  (require 'gnus-art))
+
+(defgroup org-contacts nil
+  "Options concerning contacts management."
+  :group 'org)
+
+(defcustom org-contacts-files nil
+  "List of Org files to use as contacts source.
+If 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-birthday-property "BIRTHDAY"
+  "Name of the property for contact birthday date."
+  :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)
+
+(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 ((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 (org-mode-p)
+          (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))))
+    (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 string pred action)
+    (let ((completion-ignore-case t))
+      (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 (if org-contacts-completion-ignore-case
+                       (apply-partially #'completion-table-case-fold 
completion-list)
+                     completion-list))))
+
+(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))))
+
+(add-hook 'message-mode-hook
+          (lambda ()
+            (add-to-list 'completion-at-point-functions
+                         'org-contacts-message-complete-function)))
+
+(defun org-contacts-gnus-get-name-email ()
+  "Get name and email address from Gnus message."
+  (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 (org-mode-p)
+        (org-show-context 'agenda)
+        (save-excursion
+          (and (outline-next-heading)
+               ;; show the next heading
+               (org-flag-heading nil)))))))
+
+(define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto)
+
+(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 ""))
+    (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 (or format "Birthday: %l (%Y)")
+                               `((?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)))))))
+
+(add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail)
+
+(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 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)))))))
+
+(add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address)
+
+(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."
+  (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))
+
+(provide 'org-contacts)