summaryrefslogtreecommitdiff
path: root/contrib/lisp/org-contacts.el
diff options
context:
space:
mode:
authorS├ębastien Delafond <sdelafond@gmail.com>2015-08-25 12:27:35 +0200
committerS├ębastien Delafond <sdelafond@gmail.com>2015-08-25 12:27:35 +0200
commit1be13d57dc8357576a8285c6dadc03db9e3ed7b0 (patch)
treee35b32d4dbd60cb6cea09f3c0797cc8877352def /contrib/lisp/org-contacts.el
parent4dc4918d0d667f18f3d5e3dd71e6f117ddb8af8a (diff)
Imported Upstream version 8.3.1
Diffstat (limited to 'contrib/lisp/org-contacts.el')
-rw-r--r--contrib/lisp/org-contacts.el153
1 files changed, 129 insertions, 24 deletions
diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el
index 0bc9cd7..edc09fe 100644
--- a/contrib/lisp/org-contacts.el
+++ b/contrib/lisp/org-contacts.el
@@ -155,6 +155,11 @@ The following replacements are available:
: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 (list org-contacts-email-property
org-contacts-alias-property
@@ -183,6 +188,12 @@ This overrides `org-email-link-description-format' if set."
: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")
@@ -244,30 +255,56 @@ to dead or no buffer."
(let* (todo-only
(contacts-matcher
(cdr (org-make-tags-matcher org-contacts-matcher)))
- markers result)
+ 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))
- (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))
+ (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
+ 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)))
+ (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.
@@ -500,11 +537,12 @@ 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 = (org-contacts-strip-link (car (org-contacts-split-property
- (or
- (cdr (assoc-string org-contacts-email-property
- (caddr contact)))
- ""))))
+ for email = (org-contacts-strip-link
+ (or (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))
", ")))
@@ -512,6 +550,45 @@ 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-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 (org-string-match-p
+ (concat "^" org-contacts-tags-props-prefix) string)))
+ (when completion-p
+ (let ((result
+ (mapconcat
+ 'identity
+ (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
+ (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 = (second contact)
+ if (with-current-buffer (marker-buffer marker)
+ (save-excursion
+ (goto-char marker)
+ (let (todo-only)
+ (eval (cdr (org-make-tags-matcher (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
@@ -570,8 +647,8 @@ A group FOO is composed of contacts with the tag FOO."
(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))))))
+ (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."
@@ -826,7 +903,7 @@ address."
(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)."
+ (error (format "This contact has no mail address set (no %s property)"
org-contacts-email-property)))))))
(defun org-contacts-get-icon (&optional pom)
@@ -946,7 +1023,7 @@ to do our best."
(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 (car phones-list)) "\n"))
+ (setq result (concat result "TEL:" (org-link-unescape (org-contacts-strip-link (car phones-list))) "\n"))
(setq phones-list (cdr phones-list)))
result))
(when bday
@@ -960,11 +1037,39 @@ to do our best."
"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: "
+ (first (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."
- (interactive) ; TODO ask for name?
(let* ((filename (or file org-contacts-vcard-file))
(buffer (if to-buffer
(get-buffer-create to-buffer)