contrib/lisp/org-contacts: Allow org links in properties

* contrib/lisp/org-contacts.el (org-contacts-split-property):
  Introduce a custom version of split-string that keeps org links
  intact.

* contrib/lisp/org-contacts.el (org-contacts-strip-link): Introduce a
  new function that removes brackets, description, link type and colon
  from an org link string returning the pure link target.

* contrib/lisp/org-contacts.el (provide 'org-contacts): Remove a
  redundant line.

* contrib/lisp/org-contacts.el (org-contacts-complete-group,
  org-contacts-complete-name, org-contacts-view-send-email,
  org-contacts-get-icon, org-contacts-vcard-format): Apply the new
  functions to the already existing functions extracting telephone
  numbers and email addresses from the properties.

Allowed separators for email addresses and phone numbers are `,', `;'
and whitespace.  `:' is not allowed anymore as separator to avoid
confusion with implicit links.

Examples of properties that are possible after those changes:

* Surname, Name
:PROPERTIES:
:EMAIL:    mailto:test2@test.de; [[mailto:name@test.de]] foo@bar.biz
:PHONE:    [[tel:+49 351 4129535]], +491766626196 [[+49 (351) 41295-35]]
:END:

Phone links of the form [[tel:+49 351 412 95-35][My phone number]] or
[[tel:+49 351 41295-35]] are expected.  `-', `/', `(', `)' and
whitespace characters are allowed in telephone numbers.
This commit is contained in:
Michael Strey 2013-04-26 12:29:55 +02:00 committed by Grégoire Jadi
parent 43d2cdde45
commit 1b44df7267

View file

@ -445,11 +445,11 @@ A group FOO is composed of contacts with the tag FOO."
;; returned by `org-contacts-filter'. ;; returned by `org-contacts-filter'.
for contact-name = (car contact) for contact-name = (car contact)
;; Grab the first email of the 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 (or
(cdr (assoc-string org-contacts-email-property (cdr (assoc-string org-contacts-email-property
(caddr contact))) (caddr contact)))
""))) ""))))
;; If the user has an email address, append USER <EMAIL>. ;; If the user has an email address, append USER <EMAIL>.
if email collect (org-contacts-format-email contact-name email)) if email collect (org-contacts-format-email contact-name email))
", "))) ", ")))
@ -466,14 +466,14 @@ A group FOO is composed of contacts with the tag FOO."
;; returned by `org-contacts-filter'. ;; returned by `org-contacts-filter'.
for contact-name = (car contact) for contact-name = (car contact)
;; Build the list of the user email addresses. ;; Build the list of the user email addresses.
for email-list = (split-string (or for email-list = (org-contacts-split-property (or
(cdr (assoc-string org-contacts-email-property (cdr (assoc-string org-contacts-email-property
(caddr contact))) "")) (caddr contact))) ""))
;; If the user has email addresses… ;; If the user has email addresses…
if email-list if email-list
;; … append a list of USER <EMAIL>. ;; … append a list of USER <EMAIL>.
nconc (loop for email in email-list 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 (completion-list (org-contacts-all-completions-prefix
string string
(org-uniquify completion-list)))) (org-uniquify completion-list))))
@ -738,11 +738,12 @@ address."
(org-with-point-at marker (org-with-point-at marker
(let ((emails (org-entry-get (point) org-contacts-email-property))) (let ((emails (org-entry-get (point) org-contacts-email-property)))
(if emails (if emails
(let ((email-list (split-string emails))) (let ((email-list (org-contacts-split-property emails)))
(if (and (= (length email-list) 1) (not ask)) (if (and (= (length email-list) 1) (not ask))
(compose-mail (org-contacts-format-email (compose-mail (org-contacts-format-email
(org-get-heading t) emails)) (org-get-heading t) emails))
(let ((email (completing-read "Send mail to which address: " email-list))) (let ((email (completing-read "Send mail to which address: " email-list)))
(setq email (org-contacts-strip-link email))
(org-contacts-check-mail-address email) (org-contacts-check-mail-address email)
(compose-mail (org-contacts-format-email (org-get-heading t) 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)."
@ -766,8 +767,8 @@ address."
(email-list (org-entry-get pom org-contacts-email-property)) (email-list (org-entry-get pom org-contacts-email-property))
(gravatar (gravatar
(when email-list (when email-list
(loop for email in (split-string email-list) (loop for email in (org-contacts-split-property email-list)
for gravatar = (gravatar-retrieve-synchronously email) for gravatar = (gravatar-retrieve-synchronously (org-contacts-strip-link email))
if (and gravatar if (and gravatar
(not (eq gravatar 'error))) (not (eq gravatar 'error)))
return gravatar)))) return gravatar))))
@ -849,19 +850,19 @@ to do our best."
(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)))
(concat head (concat head
(when email (progn (when email (progn
(setq emails-list (split-string email "[,;: ]+")) (setq emails-list (org-contacts-split-property email "[,; ]+"))
(setq result "") (setq result "")
(while emails-list (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))) (setq emails-list (cdr emails-list)))
result)) result))
(when addr (when addr
(format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr))) (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
(when tel (progn (when tel (progn
(setq phones-list (split-string tel "[,;: ]+")) (setq phones-list (org-contacts-split-property tel "[,; ]+"))
(setq result "") (setq result "")
(while phones-list (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))) (setq phones-list (cdr phones-list)))
result)) result))
(when bday (when bday
@ -910,7 +911,55 @@ Requires google-maps-el."
if addr if addr
collect (cons (list addr) (list :label (string-to-char (car contact))))))) 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
`split-string-default-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* ((keep-nulls (or nil omit-nulls))
(rexp (or separators split-string-default-separators))
(inputlist (split-string string rexp keep-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) (provide 'org-contacts)