diff options
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/init.el | 69 | ||||
| -rw-r--r-- | emacs/org-contacts.el | 1150 |
2 files changed, 1196 insertions, 23 deletions
diff --git a/emacs/init.el b/emacs/init.el index 3477e96..a4a1b2b 100644 --- a/emacs/init.el +++ b/emacs/init.el @@ -10,9 +10,19 @@ ("reg" "%(binary) -f %(ledger-file) reg") ("payee" "%(binary) -f %(ledger-file) reg @%(payee)") ("account" "%(binary) -f %(ledger-file) reg %(account)")))) - '(org-agenda-files + '(org-agenda-files nil) + '(org-capture-templates (quote - ("/home/blaise/org/agenda.org" "/home/blaise/org/anniversaries.org" "/home/blaise/org/repeat.org" "/home/blaise/org/todo.org" "/home/blaise/org/clocked.org" "/home/blaise/uw-madison/"))) + (("c" "Contact" entry + (file "~/org/contacts.org") + "* %(org-contacts-template-name) +:PROPERTIES: +:ADDRESS: +:EMAIL: %(org-contacts-template-email) +:PHONE: +:NOTE: +:END:" :empty-lines 0)))) + '(org-contacts-files (quote ("~/org/contacts.org"))) '(package-selected-packages (quote (exec-path-from-shell ledger-mode evil-ledger ## ledger-import treemacs-evil treemacs avy move-text es-lib helm-flyspell flycheck which-key helm-swoop evil-leader helm spaceline evil use-package))) @@ -115,26 +125,17 @@ ) (setq org-todo-keywords '((sequence "TODO" "WAITING" "|" "DONE" "DELEGATED" "CANCELED"))) (setq org-tags-column -99) -(use-package org-brain - :ensure t - :init - (setq org-brain-path "~/brain") - ;; For Evil users - (with-eval-after-load 'evil - (evil-set-initial-state 'org-brain-visualize-mode 'emacs)) - :config - (setq org-id-track-globally t) - (setq org-id-locations-file "~/.emacs.d/.org-id-locations") - (setq org-brain-visualize-default-choices 'all) - (setq org-brain-title-max-length 12) - (setq org-agenda-files '("~/org/")) - (setq org-agenda-span 1) - (setq org-agenda-start-with-log-mode t) - (setq org-agenda-start-day "0d") - (setq org-agenda-window-setup 'only-window) - (setq org-clock-mode-line-total 'today) - (setq org-duration-format (quote h:mm)) - ) +(setq org-id-track-globally t) +(setq org-id-locations-file "~/.emacs.d/.org-id-locations") +(setq org-brain-visualize-default-choices 'all) +(setq org-brain-title-max-length 12) +(setq org-agenda-files '("~/org/")) +(setq org-agenda-span 1) +(setq org-agenda-start-with-log-mode t) +(setq org-agenda-start-day "0d") +(setq org-agenda-window-setup 'only-window) +(setq org-clock-mode-line-total 'today) +(setq org-duration-format (quote h:mm)) (setq org-agenda-prefix-format '( (agenda . "%i %-12.12:c %?-12t %s") ;; file name + org-agenda-entry-type (timeline . " % s") @@ -142,7 +143,29 @@ (tags . " %i %-12:c") (search . " %i %-12:c") ) -) + ) +(load "~/source/dotfiles/emacs/org-contacts.el") +(use-package org-contacts + :ensure nil + :after org + :custom (org-contacts-files '("~/org/contacts.org")) + ) +(use-package org-capture + :ensure nil + :after org + :preface + (defvar my/org-contacts-template "* %(org-contacts-template-name) +:PROPERTIES: +:ADDRESS: +:EMAIL: +:PHONE: +:NOTE: +:END:" "Template for org-contacts.") + :custom + (org-capture-templates + `(("c" "Contact" entry (file "~/org/contacts.org"), + my/org-contacts-template + :empty-lines 0)))) ;; spaceline (use-package spaceline :ensure t) diff --git a/emacs/org-contacts.el b/emacs/org-contacts.el new file mode 100644 index 0000000..a7c268c --- /dev/null +++ b/emacs/org-contacts.el @@ -0,0 +1,1150 @@ +;;; org-contacts.el --- Contacts management + +;; Copyright (C) 2010-2014 Julien Danjou <julien@danjou.info> + +;; Author: Julien Danjou <julien@danjou.info> +;; Keywords: outlines, hypermedia, calendar +;; +;; This file is NOT part of GNU Emacs. +;; +;; This program 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. + +;; This program 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 minimal template just like +;; this: + +;; ("c" "Contacts" entry (file "~/Org/contacts.org") +;; "* %(org-contacts-template-name) +;; :PROPERTIES: +;; :EMAIL: %(org-contacts-template-email) +;; :END:"))) +;; +;; You can also use a complex template, for example: +;; +;; ("c" "Contacts" entry (file "~/Org/contacts.org") +;; "* %(org-contacts-template-name) +;; :PROPERTIES: +;; :EMAIL: %(org-contacts-template-email) +;; :PHONE: +;; :ALIAS: +;; :NICKNAME: +;; :IGNORE: +;; :ICON: +;; :NOTE: +;; :ADDRESS: +;; :BIRTHDAY: +;; :END:"))) +;; +;;; Code: + +(require 'cl) +(require 'org) +(require 'gnus-util) +(require 'gnus-art) +(require 'mail-utils) +(require 'org-agenda) +(require 'org-capture) + +(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-tel-property "PHONE" + "Name of the property for contact phone number." + :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-note-property "NOTE" + "Name of the property for contact note." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-alias-property "ALIAS" + "Name of the property for contact name alias." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-ignore-property "IGNORE" + "Name of the property, which values will be ignored when +completing or exporting to vcard." + :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-tags-props-prefix "#" + "Tags and properties prefix." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-matcher + (mapconcat #'identity + (mapcar (lambda (x) (concat x "<>\"\"")) + (list org-contacts-email-property + org-contacts-alias-property + org-contacts-tel-property + org-contacts-address-property + org-contacts-birthday-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) + +(defcustom org-contacts-enable-completion t + "Enable or not the completion in `message-mode' with `org-contacts'." + :group 'org-contacts + :type 'boolean) + +(defcustom org-contacts-complete-functions + '(org-contacts-complete-group org-contacts-complete-tags-props org-contacts-complete-name) + "List of functions used to complete contacts in `message-mode'." + :group 'org-contacts + :type 'hook) + +;; Decalre external functions and variables +(declare-function org-reverse-string "org") +(declare-function diary-ordinal-suffix "ext:diary-lib") +(declare-function wl-summary-message-number "ext:wl-summary") +(declare-function wl-address-header-extract-address "ext:wl-address") +(declare-function wl-address-header-extract-realname "ext:wl-address") +(declare-function erc-buffer-list "ext:erc") +(declare-function erc-get-channel-user-list "ext:erc") +(declare-function google-maps-static-show "ext:google-maps-static") +(declare-function elmo-message-field "ext:elmo-pipe") +(declare-function std11-narrow-to-header "ext:std11") +(declare-function std11-fetch-field "ext:std11") + +(defconst org-contacts-property-values-separators "[,; \f\t\n\r\v]+" + "The default value of separators for `org-contacts-split-property'. + +A regexp matching strings of whitespace, `,' and `;'.") + +(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.") + +(defvar org-contacts-db nil + "Org Contacts database.") + +(defvar org-contacts-last-update nil + "Last time the Org Contacts database has been updated.") + +(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-db-need-update-p () + "Determine whether `org-contacts-db' needs to be refreshed." + (or (null org-contacts-last-update) + (cl-find-if (lambda (file) + (or (time-less-p org-contacts-last-update + (elt (file-attributes file) 5)))) + (org-contacts-files)) + (org-contacts-db-has-dead-markers-p org-contacts-db))) + +(defun org-contacts-db-has-dead-markers-p (org-contacts-db) + "Returns t if at least one dead marker is found in +ORG-CONTACTS-DB. A dead marker in this case is a marker pointing +to dead or no buffer." + ;; Scan contacts list looking for dead markers, and return t at first found. + (catch 'dead-marker-found + (while org-contacts-db + (unless (marker-buffer (nth 1 (car org-contacts-db))) + (throw 'dead-marker-found t)) + (setq org-contacts-db (cdr org-contacts-db))) + nil)) + +(defun org-contacts-db () + "Return the latest Org Contacts Database." + (let* ((org--matcher-tags-todo-only nil) + (contacts-matcher (cdr (org-make-tags-matcher org-contacts-matcher))) + result) + (when (org-contacts-db-need-update-p) + (let ((progress-reporter + (make-progress-reporter "Updating Org Contacts Database..." 0 (length org-contacts-files))) + (i 0)) + (dolist (file (org-contacts-files)) + (if (catch 'nextfile + ;; if file doesn't exist and the user agrees to removing it + ;; from org-agendas-list, 'nextfile is thrown. Catch it here + ;; and skip processing the file. + ;; + ;; TODO: suppose that the user has set an org-contacts-files + ;; list that contains an element that doesn't exist in the + ;; file system: in that case, the org-agenda-files list could + ;; be updated (and saved to the customizations of the user) if + ;; it contained the same file even though the org-agenda-files + ;; list wasn't actually used. I don't think it is normal that + ;; org-contacts updates org-agenda-files in this case, but + ;; short of duplicating org-check-agenda-files and + ;; org-remove-files, I don't know how to avoid it. + ;; + ;; A side effect of the TODO is that the faulty + ;; org-contacts-files list never gets updated and thus the + ;; user is always queried about the missing files when + ;; org-contacts-db-need-update-p returns true. + (org-check-agenda-file file)) + (message "Skipped %s removed from org-agenda-files list." + (abbreviate-file-name file)) + (with-current-buffer (org-get-agenda-file-buffer file) + (unless (eq major-mode 'org-mode) + (error "File %s is not in `org-mode'" file)) + (setf result + (append result + (org-scan-tags 'org-contacts-at-point + contacts-matcher + org--matcher-tags-todo-only))))) + (progress-reporter-update progress-reporter (setq i (1+ i)))) + (setf org-contacts-db result + org-contacts-last-update (current-time)) + (progress-reporter-done progress-reporter))) + org-contacts-db)) + +(defun org-contacts-at-point (&optional pom) + "Return the contacts at point-or-marker POM or current position +if nil." + (setq pom (or pom (point))) + (org-with-point-at pom + (list (org-get-heading t) (set-marker (make-marker) pom) (org-entry-properties pom 'all)))) + +(defun org-contacts-filter (&optional name-match tags-match prop-match) + "Search for a contact matching any of NAME-MATCH, TAGS-MATCH, PROP-MATCH. +If all match values are nil, return all contacts. + +The optional PROP-MATCH argument is a single (PROP . VALUE) cons +cell corresponding to the contact properties. +" + (if (and (null name-match) + (null prop-match) + (null tags-match)) + (org-contacts-db) + (cl-loop for contact in (org-contacts-db) + if (or + (and name-match + (string-match-p name-match + (first contact))) + (and prop-match + (cl-find-if (lambda (prop) + (and (string= (car prop-match) (car prop)) + (string-match-p (cdr prop-match) (cdr prop)))) + (caddr contact))) + (and tags-match + (cl-find-if (lambda (tag) + (string-match-p tags-match tag)) + (org-split-string + (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))) + collect contact))) + +(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-try-completion-prefix (to-match collection &optional predicate) + "Custom implementation of `try-completion'. +This version works only with list and alist and it looks at all +prefixes rather than just the beginning of the string." + (cl-loop with regexp = (concat "\\b" (regexp-quote to-match)) + with ret = nil + with ret-start = nil + with ret-end = nil + + for el in collection + for string = (if (listp el) (car el) el) + + for start = (when (or (null predicate) (funcall predicate string)) + (string-match regexp string)) + + if start + do (let ((end (match-end 0)) + (len (length string))) + (if (= end len) + (cl-return t) + (cl-destructuring-bind (string start end) + (if (null ret) + (values string start end) + (org-contacts-common-substring + ret ret-start ret-end + string start end)) + (setf ret string + ret-start start + ret-end end)))) + + finally (cl-return + (replace-regexp-in-string "\\`[ \t\n]*" "" ret)))) + +(defun org-contacts-compare-strings (s1 start1 end1 s2 start2 end2 &optional ignore-case) + "Compare the contents of two strings, using `compare-strings'. + +This function works like `compare-strings' excepted that it +returns a cons. +- The CAR is the number of characters that match at the beginning. +- The CDR is T is the two strings are the same and NIL otherwise." + (let ((ret (compare-strings s1 start1 end1 s2 start2 end2 ignore-case))) + (if (eq ret t) + (cons (or end1 (length s1)) t) + (cons (1- (abs ret)) nil)))) + +(defun org-contacts-common-substring (s1 start1 end1 s2 start2 end2) + "Extract the common substring between S1 and S2. + +This function extracts the common substring between S1 and S2 and +adjust the part that remains common. + +START1 and END1 delimit the part in S1 that we know is common +between the two strings. This applies to START2 and END2 for S2. + +This function returns a list whose contains: +- The common substring found. +- The new value of the start of the known inner substring. +- The new value of the end of the known inner substring." + ;; Given two strings: + ;; s1: "foo bar baz" + ;; s2: "fooo bar baz" + ;; and the inner substring is "bar" + ;; then: start1 = 4, end1 = 6, start2 = 5, end2 = 7 + ;; + ;; To find the common substring we will compare two substrings: + ;; " oof" and " ooof" to find the beginning of the common substring. + ;; " baz" and " baz" to find the end of the common substring. + (let* ((len1 (length s1)) + (start1 (or start1 0)) + (end1 (or end1 len1)) + + (len2 (length s2)) + (start2 (or start2 0)) + (end2 (or end2 len2)) + + (new-start (car (org-contacts-compare-strings + (substring (org-reverse-string s1) (- len1 start1)) nil nil + (substring (org-reverse-string s2) (- len2 start2)) nil nil))) + + (new-end (+ end1 (car (org-contacts-compare-strings + (substring s1 end1) nil nil + (substring s2 end2) nil nil))))) + (list (substring s1 (- start1 new-start) new-end) + new-start + (+ new-start (- end1 start1))))) + +(defun org-contacts-all-completions-prefix (to-match collection &optional predicate) + "Custom version of `all-completions'. +This version works only with list and alist and it looks at all +prefixes rather than just the beginning of the string." + (cl-loop with regexp = (concat "\\b" (regexp-quote to-match)) + for el in collection + for string = (if (listp el) (car el) el) + for match? = (when (and (or (null predicate) (funcall predicate string))) + (string-match regexp string)) + if match? + collect (progn + (let ((end (match-end 0))) + (org-no-properties string) + (when (< end (length string)) + ;; Here we add a text property that will be used + ;; later to highlight the character right after + ;; the common part between each addresses. + ;; See `org-contacts-display-sort-function'. + (put-text-property end (1+ end) 'org-contacts-prefix 't string))) + string))) + +(defun org-contacts-make-collection-prefix (collection) + "Make a collection function from COLLECTION which will match on prefixes." + (lexical-let ((collection collection)) + (lambda (string predicate flag) + (cond ((eq flag nil) + (org-contacts-try-completion-prefix string collection predicate)) + ((eq flag t) + ;; `org-contacts-all-completions-prefix' has already been + ;; used to compute `all-completions'. + collection) + ((eq flag 'lambda) + (org-contacts-test-completion-prefix string collection predicate)) + ((and (listp flag) (eq (car flag) 'boundaries)) + (cl-destructuring-bind (to-ignore &rest suffix) + flag + (org-contacts-boundaries-prefix string collection predicate suffix))) + ((eq flag 'metadata) + (org-contacts-metadata-prefix string collection predicate)) + (t nil ; operation unsupported + ))))) + +(defun org-contacts-display-sort-function (completions) + "Sort function for contacts display." + (mapcar (lambda (string) + (cl-loop with len = (1- (length string)) + for i upfrom 0 to len + if (memq 'org-contacts-prefix + (text-properties-at i string)) + do (set-text-properties + i (1+ i) + (list 'font-lock-face + (if (char-equal (aref string i) + (string-to-char " ")) + ;; Spaces can't be bold. + 'underline + 'bold)) string) + else + do (set-text-properties i (1+ i) nil string) + finally (cl-return string))) + completions)) + +(defun org-contacts-test-completion-prefix (string collection predicate) + (cl-find-if (lambda (el) + (and (or (null predicate) (funcall predicate el)) + (string= string el))) + collection)) + +(defun org-contacts-boundaries-prefix (string collection predicate suffix) + (list* 'boundaries (completion-boundaries string collection predicate suffix))) + +(defun org-contacts-metadata-prefix (string collection predicate) + '(metadata . + ((cycle-sort-function . org-contacts-display-sort-function) + (display-sort-function . org-contacts-display-sort-function)))) + +(defun org-contacts-complete-group (start end string) + "Complete text at START from a group. + +A group FOO is composed of contacts with the tag FOO." + (let* ((completion-ignore-case org-contacts-completion-ignore-case) + (group-completion-p (string-match-p + (concat "^" org-contacts-group-prefix) string))) + (when group-completion-p + (let ((completion-list + (all-completions + string + (mapcar (lambda (group) + (propertize (concat org-contacts-group-prefix group) + 'org-contacts-group group)) + (org-uniquify + (cl-loop for contact in (org-contacts-filter) + nconc (org-split-string + (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))))) + (list start end + (if (= (length completion-list) 1) + ;; We've found the correct group, returns the address + (lexical-let ((tag (get-text-property 0 'org-contacts-group + (car completion-list)))) + (lambda (string pred &optional to-ignore) + (mapconcat 'identity + (cl-loop for contact in (org-contacts-filter + nil + tag) + ;; 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 = (org-contacts-strip-link + (or (car (org-contacts-split-property + (or + (cdr (assoc-string org-contacts-email-property + (cl-caddr contact))) + ""))) "")) + ;; If the user has an email address, append USER <EMAIL>. + if email collect (org-contacts-format-email contact-name email)) + ", "))) + ;; We haven't found the correct group + (completion-table-case-fold completion-list + (not org-contacts-completion-ignore-case)))))))) + +(defun org-contacts-complete-tags-props (start end string) + "Insert emails that match the tags expression. + +For example: FOO-BAR will match entries tagged with FOO but not +with BAR. + +See (org) Matching tags and properties for a complete +description." + (let* ((completion-ignore-case org-contacts-completion-ignore-case) + (completion-p (string-match-p + (concat "^" org-contacts-tags-props-prefix) string))) + (when completion-p + (let ((result + (mapconcat + 'identity + (cl-loop for contact in (org-contacts-db) + for contact-name = (car contact) + for email = (org-contacts-strip-link (or (car (org-contacts-split-property + (or + (cdr (assoc-string org-contacts-email-property + (cl-caddr contact))) + ""))) "")) + for tags = (cdr (assoc "TAGS" (nth 2 contact))) + for tags-list = (if tags + (split-string (substring (cdr (assoc "TAGS" (nth 2 contact))) 1 -1) ":") + '()) + for marker = (nth 1 contact) + if (with-current-buffer (marker-buffer marker) + (save-excursion + (goto-char marker) + (let (todo-only) + (eval (cdr (org-make-tags-matcher (cl-subseq string 1))))))) + collect (org-contacts-format-email contact-name email)) + ","))) + (when (not (string= "" result)) + ;; return (start end function) + (lexical-let* ((to-return result)) + (list start end + (lambda (string pred &optional to-ignore) to-return)))))))) + +(defun org-contacts-remove-ignored-property-values (ignore-list list) + "Remove all ignore-list's elements from list and you can use + regular expressions in the ignore list." + (cl-remove-if (lambda (el) + (cl-find-if (lambda (x) + (string-match-p x el)) + ignore-list)) + list)) + +(defun org-contacts-complete-name (start end string) + "Complete text at START with a user name and email." + (let* ((completion-ignore-case org-contacts-completion-ignore-case) + (completion-list + (cl-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 email addresses which has + ;; been expired + for ignore-list = (org-contacts-split-property + (or (cdr (assoc-string org-contacts-ignore-property + (nth 2 contact))) "")) + ;; Build the list of the user email addresses. + for email-list = (org-contacts-remove-ignored-property-values + ignore-list + (org-contacts-split-property + (or (cdr (assoc-string org-contacts-email-property + (nth 2 contact))) ""))) + ;; If the user has email addresses… + if email-list + ;; … append a list of USER <EMAIL>. + nconc (cl-loop for email in email-list + collect (org-contacts-format-email contact-name (org-contacts-strip-link email))))) + (completion-list (org-contacts-all-completions-prefix + string + (org-uniquify completion-list)))) + (when completion-list + (list start end + (org-contacts-make-collection-prefix completion-list))))) + +(defun org-contacts-message-complete-function (&optional start) + "Function used in `completion-at-point-functions' in `message-mode'." + ;; Avoid to complete in `post-command-hook'. + (when completion-in-region-mode + (remove-hook 'post-command-hook #'completion-in-region--postch)) + (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) + (lexical-let* + ((end (point)) + (start (or start + (save-excursion + (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*") + (goto-char (match-end 0)) + (point)))) + (string (buffer-substring start end))) + (run-hook-with-args-until-success + 'org-contacts-complete-functions start end string))))) + +(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))) + (cl-cadar (or (org-contacts-filter + nil + nil + (cons org-contacts-email-property (concat "\\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))))) + +(with-no-warnings (defvar date)) ;; unprefixed, from calendar.el +(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 'ISO) + (entry "")) + (unless format (setq format org-contacts-birthday-format)) + (cl-loop for contact in (org-contacts-filter) + for anniv = (let ((anniv (cdr (assoc-string + (or field org-contacts-birthday-property) + (nth 2 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 () + "Return the contact icon as a 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-prefix-format (propertize + "%(org-contacts-icon-as-string)% s%(org-contacts-irc-number-of-unread-messages) " + '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-name (name) + "Trim any local formatting to get a bare NAME." + ;; Remove radio targets characters + (replace-regexp-in-string org-radio-target-regexp "\\1" name)) + +(defun org-contacts-format-email (name email) + "Format an EMAIL address corresponding to NAME." + (unless email + (error "`email' cannot be nul")) + (if name + (concat (org-contacts-format-name 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)) + +(defun org-contacts-setup-completion-at-point () + "Add `org-contacts-message-complete-function' as a new function +to complete the thing at point." + (add-to-list 'completion-at-point-functions + 'org-contacts-message-complete-function)) + +(defun org-contacts-unload-hook () + (remove-hook 'message-mode-hook 'org-contacts-setup-completion-at-point)) + +(when (and org-contacts-enable-completion + (boundp 'completion-at-point-functions)) + (add-hook 'message-mode-hook 'org-contacts-setup-completion-at-point)) + +(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 (and (boundp 'wl-summary-buffer-elmo-folder) + 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 (org-contacts-split-property 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))) + (setq email (org-contacts-strip-link email)) + (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 (org-contacts-split-property email-list) + for gravatar = (gravatar-retrieve-synchronously (org-contacts-strip-link 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)) + +(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 (nth 2 contact)) + (name (org-contacts-vcard-escape (car contact))) + (n (org-contacts-vcard-encode-name name)) + (email (cdr (assoc-string org-contacts-email-property properties))) + (tel (cdr (assoc-string org-contacts-tel-property properties))) + (ignore-list (cdr (assoc-string org-contacts-ignore-property properties))) + (ignore-list (when ignore-list + (org-contacts-split-property ignore-list))) + (note (cdr (assoc-string org-contacts-note-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)) + emails-list result phones-list) + (concat head + (when email (progn + (setq emails-list (org-contacts-remove-ignored-property-values ignore-list (org-contacts-split-property email))) + (setq result "") + (while emails-list + (setq result (concat result "EMAIL:" (org-contacts-strip-link (car emails-list)) "\n")) + (setq emails-list (cdr emails-list))) + result)) + (when addr + (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr))) + (when tel (progn + (setq phones-list (org-contacts-remove-ignored-property-values ignore-list (org-contacts-split-property tel))) + (setq result "") + (while phones-list + (setq result (concat result "TEL:" (org-contacts-strip-link (org-link-unescape (car phones-list))) "\n")) + (setq phones-list (cdr phones-list))) + result)) + (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)) + (when note (format "NOTE:%s\n" note)) + "END:VCARD\n\n"))) + +(defun org-contacts-export-as-vcard (&optional name file to-buffer) + "Export org contacts to V-Card 3.0. + +By default, all contacts are exported to `org-contacts-vcard-file'. + +When NAME is \\[universal-argument], prompts for a contact name. + +When NAME is \\[universal-argument] \\[universal-argument], +prompts for a contact name and a file name where to export. + +When NAME is \\[universal-argument] \\[universal-argument] +\\[universal-argument], prompts for a contact name and a buffer where to export. + +If the function is not called interactively, all parameters are +passed to `org-contacts-export-as-vcard-internal'." + (interactive "P") + (when (called-interactively-p 'any) + (cl-psetf name + (when name + (read-string "Contact name: " + (nth 0 (org-contacts-at-point)))) + file + (when (equal name '(16)) + (read-file-name "File: " nil org-contacts-vcard-file)) + to-buffer + (when (equal name '(64)) + (read-buffer "Buffer: ")))) + (org-contacts-export-as-vcard-internal name file to-buffer)) + +(defun org-contacts-export-as-vcard-internal (&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." + (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) + (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 + (cl-loop + for contact in (org-contacts-filter name) + for addr = (cdr (assoc-string org-contacts-address-property (nth 2 contact))) + if addr + collect (cons (list addr) (list :label (string-to-char (car contact))))))) + +(defun org-contacts-strip-link (link) + "Remove brackets, description, link type and colon from an org +link string and return the pure link target." + (let (startpos colonpos endpos) + (setq startpos (string-match (regexp-opt '("[[tel:" "[[mailto:")) link)) + (if startpos + (progn + (setq colonpos (string-match ":" link)) + (setq endpos (string-match "\\]" link)) + (if endpos (substring link (1+ colonpos) endpos) link)) + (progn + (setq startpos (string-match "mailto:" link)) + (setq colonpos (string-match ":" link)) + (if startpos (substring link (1+ colonpos)) link))))) + +;; Add the link type supported by org-contacts-strip-link +;; so everything is in order for its use in Org files +(org-link-set-parameters "tel") + +(defun org-contacts-split-property (string &optional separators omit-nulls) + "Custom version of `split-string'. +Split a property STRING into sub-strings bounded by matches +for SEPARATORS but keep Org links intact. + +The beginning and end of STRING, and each match for SEPARATORS, are +splitting points. The substrings matching SEPARATORS are removed, and +the substrings between the splitting points are collected as a list, +which is returned. + +If SEPARATORS is non-nil, it should be a regular expression +matching text which separates, but is not part of, the +substrings. If nil it defaults to `org-contacts-property-values-separators', +normally \"[,; \f\t\n\r\v]+\", and OMIT-NULLS is forced to t. + +If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so +that for the default value of SEPARATORS leading and trailing whitespace +are effectively trimmed). If nil, all zero-length substrings are retained." + (let* ((omit-nulls (if separators omit-nulls t)) + (rexp (or separators org-contacts-property-values-separators)) + (inputlist (split-string string rexp omit-nulls)) + (linkstring "") + (bufferstring "") + (proplist (list ""))) + (while inputlist + (setq bufferstring (pop inputlist)) + (if (string-match "\\[\\[" bufferstring) + (progn + (setq linkstring (concat bufferstring " ")) + (while (not (string-match "\\]\\]" bufferstring)) + (setq bufferstring (pop inputlist)) + (setq linkstring (concat linkstring bufferstring " "))) + (setq proplist (cons (org-trim linkstring) proplist))) + (setq proplist (cons bufferstring proplist)))) + (cdr (reverse proplist)))) + +(provide 'org-contacts) + +;;; org-contacts.el ends here |