1 ;;; org-contacts.el --- Contacts management
3 ;; Copyright (C) 2010, 2011 Julien Danjou <julien@danjou.info>
5 ;; Author: Julien Danjou <julien@danjou.info>
6 ;; Keywords: outlines, hypermedia, calendar
8 ;; This file is NOT part of GNU Emacs.
10 ;; GNU Emacs 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.
15 ;; GNU Emacs 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.
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;; This file contains the code for managing your contacts into Org-mode.
28 ;; To enter new contacts, you can use `org-capture' and a template just like
31 ;; ("c" "Contacts" entry (file "~/Org/contacts.org")
32 ;; "* %(org-contacts-template-name)
34 ;; :EMAIL: %(org-contacts-template-email)
42 (defgroup org-contacts nil
43 "Options concerning contacts management."
46 (defcustom org-contacts-files nil
47 "List of Org files to use as contacts source.
48 If set to nil, all your Org files will be used."
52 (defcustom org-contacts-email-property
"EMAIL"
53 "Name of the property for contact email address."
57 (defcustom org-contacts-birthday-property
"BIRTHDAY"
58 "Name of the property for contact birthday date."
62 (defcustom org-contacts-birthday-format
"Birthday: %l (%Y)"
63 "Format of the anniversary agenda entry. The following replacements are available:
66 %l - Link to the heading
68 %Y - Number of year (ordinal)"
72 (defcustom org-contacts-last-read-mail-property
"LAST_READ_MAIL"
73 "Name of the property for contact last read email link storage."
77 (defcustom org-contacts-icon-property
"ICON"
78 "Name of the property for contact icon."
82 (defcustom org-contacts-nickname-property
"NICKNAME"
83 "Name of the property for IRC nickname match."
87 (defcustom org-contacts-icon-size
32
88 "Size of the contacts icons."
92 (defcustom org-contacts-icon-use-gravatar
(fboundp 'gravatar-retrieve
)
93 "Whether use Gravatar to fetch contact icons."
97 (defcustom org-contacts-completion-ignore-case t
98 "Ignore case when completing contacts."
100 :group
'org-contacts
)
102 (defcustom org-contacts-group-prefix
"+"
105 :group
'org-contacts
)
107 (defcustom org-contacts-matcher
(concat org-contacts-email-property
"<>\"\"")
108 "Matching rule for finding heading that are contacts.
109 This can be a tag name, or a property check."
111 :group
'org-contacts
)
113 (defcustom org-contacts-email-link-description-format
"%s (%d)"
114 "Format used to store links to email.
115 This overrides `org-email-link-description-format' if set."
119 (defvar org-contacts-keymap
120 (let ((map (make-sparse-keymap)))
121 (define-key map
"M" 'org-contacts-view-send-email
)
122 (define-key map
"i" 'org-contacts-view-switch-to-irc-buffer
)
124 "The keymap used in `org-contacts' result list.")
126 (defun org-contacts-files ()
127 "Return list of Org files to use for contact management."
128 (or org-contacts-files
(org-agenda-files t
'ifmode
)))
130 (defun org-contacts-filter (&optional name-match tags-match
)
131 "Search for a contact maching NAME-MATCH and TAGS-MATCH.
132 If both match values are nil, return all contacts."
135 (cdr (org-make-tags-matcher tags-match
))
139 '(org-string-match-p name-match
(org-get-heading t
))
142 (cdr (org-make-tags-matcher org-contacts-matcher
)))
144 (dolist (file (org-contacts-files))
145 (org-check-agenda-file file
)
146 (with-current-buffer (org-get-agenda-file-buffer file
)
148 (error "File %s is no in `org-mode'" file
))
150 '(add-to-list 'markers
(set-marker (make-marker) (point)))
151 `(and ,contacts-matcher
,tags-matcher
,name-matcher
))))
152 (dolist (marker markers result
)
153 (org-with-point-at marker
155 (list (org-get-heading t
) marker
(org-entry-properties marker
'all
)))))))
157 (when (not (fboundp 'completion-table-case-fold
))
158 ;; That function is new in Emacs 24...
159 (defun completion-table-case-fold (table string pred action
)
160 (let ((completion-ignore-case t
))
161 (complete-with-action action table string pred
))))
163 (defun org-contacts-complete-name (&optional start
)
164 "Complete text at START with a user name and email."
168 (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
169 (goto-char (match-end 0))
171 (orig (buffer-substring start end
))
172 (completion-ignore-case org-contacts-completion-ignore-case
)
173 (group-completion-p (org-string-match-p (concat "^" org-contacts-group-prefix
) orig
))
175 (if group-completion-p
176 (mapcar (lambda (group) (propertize (concat org-contacts-group-prefix group
) 'org-contacts-group group
))
178 (loop for contact in
(org-contacts-filter)
180 nconc
(org-split-string
181 (or (cdr (assoc-string "ALLTAGS" (caddr contact
))) "") ":"))))
182 (loop for contact in
(org-contacts-filter)
183 ;; The contact name is always the car of the assoc-list
184 ;; returned by `org-contacts-filter'.
185 for contact-name
= (car contact
)
186 ;; Build the list of the user email addresses.
187 for email-list
= (split-string (or
188 (cdr (assoc-string org-contacts-email-property
(caddr contact
)))
190 ;; If the user has email addresses…
192 ;; … append a list of USER <EMAIL>.
193 nconc
(loop for email in email-list
194 collect
(org-contacts-format-email contact-name email
)))))
195 (completion-list (all-completions orig completion-list
)))
196 ;; If we are completing a group, and that's the only group, just return
198 (when (and group-completion-p
199 (= (length completion-list
) 1))
200 (setq completion-list
201 (list (concat (car completion-list
) ";: "
203 (loop for contact in
(org-contacts-filter
205 (get-text-property 0 'org-contacts-group
(car completion-list
)))
206 ;; The contact name is always the car of the assoc-list
207 ;; returned by `org-contacts-filter'.
208 for contact-name
= (car contact
)
209 ;; Grab the first email of the contact
210 for email
= (car (split-string (or
211 (cdr (assoc-string org-contacts-email-property
(caddr contact
)))
213 ;; If the user has an email address, append USER <EMAIL>.
214 if email collect
(org-contacts-format-email contact-name email
))
216 (list start end
(if org-contacts-completion-ignore-case
217 (apply-partially #'completion-table-case-fold completion-list
)
220 (defun org-contacts-message-complete-function ()
221 "Function used in `completion-at-point-functions' in `message-mode'."
222 (let ((mail-abbrev-mode-regexp
223 "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
224 (when (mail-abbrev-in-expansion-header-p)
225 (org-contacts-complete-name))))
227 (add-hook 'message-mode-hook
229 (add-to-list 'completion-at-point-functions
230 'org-contacts-message-complete-function
)))
232 (defun org-contacts-gnus-get-name-email ()
233 "Get name and email address from Gnus message."
234 (gnus-with-article-headers
235 (mail-extract-address-components
236 (or (mail-fetch-field "From") ""))))
238 (defun org-contacts-gnus-article-from-get-marker ()
239 "Return a marker for a contact based on From."
240 (let* ((address (org-contacts-gnus-get-name-email))
242 (email (cadr address
)))
243 (cadar (or (org-contacts-filter
245 (concat org-contacts-email-property
"={\\b" (regexp-quote email
) "\\b}"))
248 (concat "^" name
"$")))))))
250 (defun org-contacts-gnus-article-from-goto ()
251 "Go to contact in the From address of current Gnus message."
253 (let ((marker (org-contacts-gnus-article-from-get-marker)))
255 (switch-to-buffer-other-window (marker-buffer marker
))
258 (org-show-context 'agenda
)
260 (and (outline-next-heading)
261 ;; show the next heading
262 (org-flag-heading nil
)))))))
264 (defun org-contacts-anniversaries (&optional field format
)
265 "Compute FIELD anniversary for each contact, returning FORMAT.
266 Default FIELD value is \"BIRTHDAY\".
268 Format is a string matching the following format specification:
271 %l - Link to the heading
273 %Y - Number of year (ordinal)"
274 (let ((calendar-date-style 'american
)
276 (unless format
(setq format org-contacts-birthday-format
))
277 (loop for contact in
(org-contacts-filter)
278 for anniv
= (let ((anniv (cdr (assoc-string
279 (or field org-contacts-birthday-property
)
282 (calendar-gregorian-from-absolute
283 (org-time-string-to-absolute anniv
))))
284 ;; Use `diary-anniversary' to compute anniversary.
285 if
(and anniv
(apply 'diary-anniversary anniv
))
286 collect
(format-spec format
287 `((?l .
,(org-with-point-at (cadr contact
) (org-store-link nil
)))
288 (?h .
,(car contact
))
289 (?y .
,(- (calendar-extract-year date
)
290 (calendar-extract-year anniv
)))
291 (?Y .
,(let ((years (- (calendar-extract-year date
)
292 (calendar-extract-year anniv
))))
293 (format "%d%s" years
(diary-ordinal-suffix years
)))))))))
295 (defun org-completing-read-date (prompt collection
296 &optional predicate require-match initial-input
297 hist def inherit-input-method
)
298 "Like `completing-read' but reads a date.
299 Only PROMPT and DEF are really used."
300 (org-read-date nil nil nil prompt nil def
))
302 (add-to-list 'org-property-set-functions-alist
303 `(,org-contacts-birthday-property . org-completing-read-date
))
305 (defun org-contacts-template-name (&optional return-value
)
306 "Try to return the contact name for a template.
307 If not found return RETURN-VALUE or something that would ask the user."
308 (or (car (org-contacts-gnus-get-name-email))
312 (defun org-contacts-template-email (&optional return-value
)
313 "Try to return the contact email for a template.
314 If not found return RETURN-VALUE or something that would ask the user."
315 (or (cadr (org-contacts-gnus-get-name-email))
317 (concat "%^{" org-contacts-email-property
"}p")))
319 (defun org-contacts-gnus-store-last-mail ()
320 "Store a link between mails and contacts.
322 This function should be called from `gnus-article-prepare-hook'."
323 (let ((marker (org-contacts-gnus-article-from-get-marker)))
325 (with-current-buffer (marker-buffer marker
)
328 (let* ((org-email-link-description-format (or org-contacts-email-link-description-format
329 org-email-link-description-format
))
330 (link (gnus-with-article-buffer (org-store-link nil
))))
331 (org-set-property org-contacts-last-read-mail-property link
)))))))
333 (defun org-contacts-icon-as-string ()
334 (let ((image (org-contacts-get-icon)))
336 (propertize "-" 'display
340 `'(space :width
(,org-contacts-icon-size
)))
345 (defun org-contacts (name)
346 "Create agenda view for contacts matching NAME."
347 (interactive (list (read-string "Name: ")))
348 (let ((org-agenda-files (org-contacts-files))
349 (org-agenda-skip-function
350 (lambda () (org-agenda-skip-if nil
`(notregexp ,name
))))
351 (org-agenda-format (propertize
352 "%(org-contacts-icon-as-string)% p% s%(org-contacts-irc-number-of-unread-messages)%+T"
353 'keymap org-contacts-keymap
))
354 (org-agenda-overriding-header
355 (or org-agenda-overriding-header
356 (concat "List of contacts matching `" name
"':"))))
357 (setq org-agenda-skip-regexp name
)
358 (org-tags-view nil org-contacts-matcher
)
359 (with-current-buffer org-agenda-buffer-name
360 (setq org-agenda-redo-command
361 (list 'org-contacts name
)))))
363 (defun org-contacts-completing-read (prompt
365 initial-input hist def inherit-input-method
)
366 "Call `completing-read' with contacts name as collection."
368 prompt
(org-contacts-filter) predicate t initial-input hist def inherit-input-method
))
370 (defun org-contacts-format-email (name email
)
371 "Format a mail address."
373 (error "`email' cannot be nul"))
375 (concat name
" <" email
">")
378 (defun org-contacts-check-mail-address (mail)
379 "Add MAIL address to contact at point if it does not have it."
380 (let ((mails (org-entry-get (point) org-contacts-email-property
)))
381 (unless (member mail
(split-string mails
))
383 (format "Do you want to this address to %s?" (org-get-heading t
)))
384 (org-set-property org-contacts-email-property
(concat mails
" " mail
))))))
386 (defun org-contacts-gnus-check-mail-address ()
387 "Check that contact has the current address recorded.
388 This function should be called from `gnus-article-prepare-hook'."
389 (let ((marker (org-contacts-gnus-article-from-get-marker)))
391 (org-with-point-at marker
392 (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))
394 (defun org-contacts-gnus-insinuate ()
395 "Add some hooks for Gnus user.
396 This adds `org-contacts-gnus-check-mail-address' and
397 `org-contacts-gnus-store-last-mail' to
398 `gnus-article-prepare-hook'. It also adds a binding on `;' in
399 `gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
402 (define-key gnus-summary-mode-map
";" 'org-contacts-gnus-article-from-goto
)
403 (add-hook 'gnus-article-prepare-hook
'org-contacts-gnus-check-mail-address
)
404 (add-hook 'gnus-article-prepare-hook
'org-contacts-gnus-store-last-mail
))
406 (defun org-contacts-view-send-email (&optional ask
)
407 "Send email to the contact at point.
408 If ASK is set, ask for the email address even if there's only one address."
410 (let ((marker (org-get-at-bol 'org-hd-marker
)))
411 (org-with-point-at marker
412 (let ((emails (org-entry-get (point) org-contacts-email-property
)))
414 (let ((email-list (split-string emails
)))
415 (if (and (= (length email-list
) 1) (not ask
))
416 (compose-mail (org-contacts-format-email
417 (org-get-heading t
) emails
))
418 (let ((email (completing-read "Send mail to which address: " email-list
)))
419 (org-contacts-check-mail-address email
)
420 (compose-mail (org-contacts-format-email (org-get-heading t
) email
)))))
421 (error (format "This contact has no mail address set (no %s property)."
422 org-contacts-email-property
)))))))
424 (defun org-contacts-get-icon (&optional pom
)
425 "Get icon for contact at POM."
426 (setq pom
(or pom
(point)))
428 ;; Use `org-contacts-icon-property'
429 (let ((image-data (org-entry-get pom org-contacts-icon-property
)))
432 (if (fboundp 'gnus-rescale-image
)
433 (gnus-rescale-image (create-image image-data
)
434 (cons org-contacts-icon-size org-contacts-icon-size
))
435 (create-image image-data
)))))
436 ;; Next, try Gravatar
437 (when org-contacts-icon-use-gravatar
438 (let* ((gravatar-size org-contacts-icon-size
)
439 (email-list (org-entry-get pom org-contacts-email-property
))
442 (loop for email in
(split-string email-list
)
443 for gravatar
= (gravatar-retrieve-synchronously email
)
445 (not (eq gravatar
'error
)))
447 (when gravatar
(throw 'icon gravatar
))))))
449 (defun org-contacts-irc-buffer (&optional pom
)
450 "Get the IRC buffer associated with the entry at POM."
451 (setq pom
(or pom
(point)))
452 (let ((nick (org-entry-get pom org-contacts-nickname-property
)))
454 (let ((buffer (get-buffer nick
)))
456 (with-current-buffer buffer
457 (when (eq major-mode
'erc-mode
)
460 (defun org-contacts-irc-number-of-unread-messages (&optional pom
)
461 "Return the number of unread messages for contact at POM."
462 (when (boundp 'erc-modified-channels-alist
)
463 (let ((number (cadr (assoc (org-contacts-irc-buffer pom
) erc-modified-channels-alist
))))
465 (format (concat "%3d unread message" (if (> number
1) "s" " ") " ") number
)
466 (make-string 21 ?
)))))
468 (defun org-contacts-view-switch-to-irc-buffer ()
469 "Switch to the IRC buffer of the current contact if it has one."
471 (let ((marker (org-get-at-bol 'org-hd-marker
)))
472 (org-with-point-at marker
473 (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
475 (defun org-contacts-completing-read-nickname (prompt collection
476 &optional predicate require-match initial-input
477 hist def inherit-input-method
)
478 "Like `completing-read' but reads a nickname."
479 (org-completing-read prompt
(append collection
(erc-nicknames-list)) predicate require-match
480 initial-input hist def inherit-input-method
))
482 (defun erc-nicknames-list ()
483 "Return all nicknames of all ERC buffers."
484 (loop for buffer in
(erc-buffer-list)
485 nconc
(with-current-buffer buffer
486 (loop for user-entry in
(mapcar 'car
(erc-get-channel-user-list))
487 collect
(elt user-entry
1)))))
489 (add-to-list 'org-property-set-functions-alist
490 `(,org-contacts-nickname-property . org-contacts-completing-read-nickname
))
492 (provide 'org-contacts
)