diff options
Diffstat (limited to 'contrib/lisp/org-contacts.el')
| -rw-r--r-- | contrib/lisp/org-contacts.el | 222 |
1 files changed, 178 insertions, 44 deletions
diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el index a3c4aed..97171d0 100644 --- a/contrib/lisp/org-contacts.el +++ b/contrib/lisp/org-contacts.el @@ -25,7 +25,7 @@ ;; 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 +;; To enter new contacts, you can use `org-capture' and a minimal template just like ;; this: ;; ("c" "Contacts" entry (file "~/Org/contacts.org") @@ -34,6 +34,22 @@ ;; :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: (eval-when-compile @@ -86,6 +102,12 @@ When set to nil, all your Org files will be used." :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. @@ -174,6 +196,11 @@ This overrides `org-email-link-description-format' if set." (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) @@ -197,7 +224,20 @@ This overrides `org-email-link-description-format' if set." (org-find-if (lambda (file) (or (time-less-p org-contacts-last-update (elt (file-attributes file) 5)))) - (org-contacts-files)))) + (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." @@ -206,28 +246,37 @@ This overrides `org-email-link-description-format' if set." (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))) + (let ((progress-reporter + (make-progress-reporter "Updating Org Contacts Database..." 0 (length org-contacts-files))) + (i 0)) + (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)) + (progress-reporter-update progress-reporter (setq i (1+ i)))) + (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)) + (progress-reporter-done progress-reporter))) 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." +(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) (loop for contact in (org-contacts-db) @@ -235,6 +284,11 @@ If both match values are nil, return all contacts." (and name-match (org-string-match-p name-match (first contact))) + (and prop-match + (org-find-if (lambda (prop) + (and (string= (car prop-match) (car prop)) + (org-string-match-p (cdr prop-match) (cdr prop)))) + (caddr contact))) (and tags-match (org-find-if (lambda (tag) (org-string-match-p tags-match tag)) @@ -411,7 +465,8 @@ prefixes rather than just the beginning of the string." (defun org-contacts-metadata-prefix (string collection predicate) '(metadata . - ((display-sort-function . org-contacts-display-sort-function)))) + ((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. @@ -433,7 +488,7 @@ A group FOO is composed of contacts with the tag FOO." (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))))) (list start end (if (= (length completion-list) 1) - ;; We've foudn the correct group, returns the address + ;; 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) @@ -445,11 +500,11 @@ A group FOO is composed of contacts with the tag FOO." ;; returned by `org-contacts-filter'. for contact-name = (car contact) ;; Grab the first email of the contact - for email = (car (split-string + for email = (org-contacts-strip-link (car (org-contacts-split-property (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)) ", "))) @@ -457,6 +512,16 @@ A group FOO is composed of contacts with the tag FOO." (completion-table-case-fold completion-list (not org-contacts-completion-ignore-case)))))))) + +(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." + (org-remove-if (lambda (el) + (org-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) @@ -465,15 +530,23 @@ A group FOO is composed of contacts with the tag FOO." ;; 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 + (caddr contact))) "")) ;; Build the list of the user email addresses. - for email-list = (split-string (or - (cdr (assoc-string org-contacts-email-property - (caddr contact))) "")) + for email-list = (org-contacts-remove-ignored-property-values + ignore-list + (org-contacts-split-property + (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)))) + collect (org-contacts-format-email contact-name (org-contacts-strip-link email))))) (completion-list (org-contacts-all-completions-prefix string (org-uniquify completion-list)))) @@ -514,7 +587,8 @@ A group FOO is composed of contacts with the tag FOO." (email (cadr address))) (cadar (or (org-contacts-filter nil - (concat org-contacts-email-property "={\\b" (regexp-quote email) "\\b}")) + nil + (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b"))) (when name (org-contacts-filter (concat "^" name "$"))))))) @@ -682,12 +756,18 @@ 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)) +(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 - (lambda () - (add-to-list 'completion-at-point-functions - 'org-contacts-message-complete-function)))) + (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. @@ -738,11 +818,12 @@ address." (org-with-point-at marker (let ((emails (org-entry-get (point) org-contacts-email-property))) (if emails - (let ((email-list (split-string 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)." @@ -766,8 +847,8 @@ address." (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) + (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)))) @@ -841,27 +922,31 @@ to do our best." (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))) + (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))) + (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 (split-string email "[,;: ]+")) + (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:" (car emails-list) "\n")) + (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 (split-string tel "[,;: ]+")) + (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:" (car phones-list) "\n")) + (setq result (concat result "TEL:" (org-contacts-strip-link (car phones-list)) "\n")) (setq phones-list (cdr phones-list))) result)) (when bday @@ -910,7 +995,56 @@ Requires google-maps-el." if addr collect (cons (list addr) (list :label (string-to-char (car contact))))))) -(provide 'org-contacts) +(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))))) + +(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) |