diff options
Diffstat (limited to 'contrib/lisp/org-contacts.el')
| -rw-r--r-- | contrib/lisp/org-contacts.el | 562 |
1 files changed, 429 insertions, 133 deletions
diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el index bc52648..a3c4aed 100644 --- a/contrib/lisp/org-contacts.el +++ b/contrib/lisp/org-contacts.el @@ -1,18 +1,18 @@ ;;; org-contacts.el --- Contacts management -;; Copyright (C) 2010-2012 Julien Danjou <julien@danjou.info> +;; Copyright (C) 2010-2013 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 +;; 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. -;; GNU Emacs is distributed in the hope that it will be useful, +;; 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. @@ -39,17 +39,20 @@ (eval-when-compile (require 'cl)) -(eval-and-compile - (require 'org)) +(require 'org) (require 'gnus-util) +(require 'gnus-art) +(require 'mail-utils) +(require 'org-agenda) +(require 'org-capture) (defgroup org-contacts nil - "Options concerning contacts management." + "Options about 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." +When set to nil, all your Org files will be used." :type '(repeat file) :group 'org-contacts) @@ -58,6 +61,11 @@ If set to nil, all your Org files will be used." :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 @@ -68,8 +76,20 @@ If set to nil, all your Org files will be used." :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-birthday-format "Birthday: %l (%Y)" - "Format of the anniversary agenda entry. The following replacements are available: + "Format of the anniversary agenda entry. +The following replacements are available: %h - Heading name %l - Link to the heading @@ -113,7 +133,13 @@ If set to nil, all your Org files will be used." :type 'string :group 'org-contacts) -(defcustom org-contacts-matcher (concat org-contacts-email-property "<>\"\"") +(defcustom org-contacts-matcher + (mapconcat 'identity (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 @@ -130,6 +156,24 @@ This overrides `org-email-link-description-format' if set." :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) + +;; 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") + (defvar org-contacts-keymap (let ((map (make-sparse-keymap))) (define-key map "M" 'org-contacts-view-send-email) @@ -137,38 +181,66 @@ This overrides `org-email-link-description-format' if set." 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) + (org-find-if (lambda (file) + (or (time-less-p org-contacts-last-update + (elt (file-attributes file) 5)))) + (org-contacts-files)))) + +(defun org-contacts-db () + "Return the latest Org Contacts Database." + (let* (todo-only + (contacts-matcher + (cdr (org-make-tags-matcher org-contacts-matcher))) + markers result) + (when (org-contacts-db-need-update-p) + (message "Update Org Contacts Database") + (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))) + contacts-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))))) + (setf org-contacts-db result + org-contacts-last-update (current-time))) + org-contacts-db)) + (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))))))) + (if (and (null name-match) + (null tags-match)) + (org-contacts-db) + (loop for contact in (org-contacts-db) + if (or + (and name-match + (org-string-match-p name-match + (first contact))) + (and tags-match + (org-find-if (lambda (tag) + (org-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... @@ -177,67 +249,256 @@ If both match values are nil, return all contacts." (let ((completion-ignore-case (not dont-fold))) (complete-with-action action table string pred))))) -(defun org-contacts-complete-name (&optional start) +(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." + (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) + (return t) + (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 (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." + (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)) + (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) + (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 (return string))) + completions)) + +(defun org-contacts-test-completion-prefix (string collection predicate) + ;; Prevents `org-find-if' from redefining `predicate' and going into + ;; an infinite loop. + (lexical-let ((predicate predicate)) + (org-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 . + ((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 (org-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 + (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 foudn 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 + (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 = (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)) + ", "))) + ;; We haven't found the correct group + (completion-table-case-fold completion-list + (not org-contacts-completion-ignore-case)))))))) + +(defun org-contacts-complete-name (start end string) "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)) + (let* ((completion-ignore-case org-contacts-completion-ignore-case) (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 () + (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 (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) - (org-contacts-complete-name)))) + (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))) + (or (org-contacts-complete-group start end string) + (org-contacts-complete-name start end string)))))) (defun org-contacts-gnus-get-name-email () "Get name and email address from Gnus message." @@ -272,6 +533,7 @@ If both match values are nil, return all contacts." ;; show the next heading (org-flag-heading nil))))))) +(org-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\". @@ -342,6 +604,7 @@ This function should be called from `gnus-article-prepare-hook'." (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 @@ -359,9 +622,9 @@ This function should be called from `gnus-article-prepare-hook'." (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-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 "':")))) @@ -378,12 +641,17 @@ This function should be called from `gnus-article-prepare-hook'." (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 a mail address." + "Format an EMAIL address corresponding to NAME." (unless email (error "`email' cannot be nul")) (if name - (concat name " <" email ">") + (concat (org-contacts-format-name name) " <" email ">") email)) (defun org-contacts-check-mail-address (mail) @@ -406,7 +674,7 @@ This function should be called from `gnus-article-prepare-hook'." "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-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) @@ -414,7 +682,8 @@ This adds `org-contacts-gnus-check-mail-address' and (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) +(when (and org-contacts-enable-completion + (boundp 'completion-at-point-functions)) (add-hook 'message-mode-hook (lambda () (add-to-list 'completion-at-point-functions @@ -426,18 +695,19 @@ 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 + ((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)))))) + (prog1 + (std11-fetch-field "From") + (widen)))))) (defun org-contacts-wl-get-name-email () - "Get name and email address from wanderlust 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 @@ -446,13 +716,14 @@ See `org-contacts-wl-get-from-header-content' for limitations." (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." +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 wl. + "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 @@ -460,7 +731,8 @@ If not found return RETURN-VALUE or something that would ask the user." (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." +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 @@ -536,24 +808,31 @@ If ASK is set, ask for the email address even if there's only one address." (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)))))) + (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 use in the VCard format. -Thanks to http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el for the regexp." + "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)))) + (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." + "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) @@ -561,16 +840,30 @@ Org-contacts does not specify how to encode the name. So we try to do our best." (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)))) + (email (cdr (assoc-string org-contacts-email-property properties))) + (tel (cdr (assoc-string org-contacts-tel-property properties))) + (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))) (concat head - (when email (format "EMAIL:%s\n" email)) + (when email (progn + (setq emails-list (split-string email "[,;: ]+")) + (setq result "") + (while emails-list + (setq result (concat result "EMAIL:" (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 (split-string tel "[,;: ]+")) + (setq result "") + (while phones-list + (setq result (concat result "TEL:" (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" @@ -578,44 +871,47 @@ Org-contacts does not specify how to encode the name. So we try to do our best." (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 all contacts matching NAME as VCard 3.0. It 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." + "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)))) - + (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))) - + do (insert (org-contacts-vcard-format contact))) (if to-buffer (current-buffer) - (progn (save-buffer) (kill-buffer))))) + (progn (save-buffer) (kill-buffer))))) (defun org-contacts-show-map (&optional name) - "Show contacts on a map. Requires google-maps-el." + "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))))))) + 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) (provide 'org-contacts) + +;;; org-contacts.el ends here |