On Tue, Apr 09, 2013 at 09:31:40AM +0200, Michael Strey wrote:
[...]
> The problem is on the side of org-contacts. Org-contacts does not
> support links in its properties.
[...]
> This shortcoming effects not only the phone links but email links as
> well.
Attached is a patch to allow org links in org-contacts properties.
It allows entries like in the following example without effecting
org-contacts current functions.
#+BEGIN_SRC org
* Surname, Name
:PROPERTIES:
:EMAIL: mailto:te...@test.de; [[mailto:n...@test.de]] f...@bar.biz
:PHONE: [[tel:+49 351 4129535]], +491766626196 [[+49 (351) 41295-35]]
:END:
#+END_SRC
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.
--
Michael Strey
www.strey.biz
From 69ae791cd552bacdcbc99af99a82ab699fa16d36 Mon Sep 17 00:00:00 2001
From: Michael Strey <mst...@strey.biz>
Date: Fri, 12 Apr 2013 12:33:16 +0200
Subject: [PATCH 174/174] Org-contacts: Allow org links in properties
* org-contacts.el (org-contacts-split-property, chomp): Introduce a custom
version of split-string that keeps org links intact. `chomp' is a
helper function for `org-contacts-split-property'.
* 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 key.
* 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 implizit links.
Examples of properties that are possible after those changes:
* Surname, Name
:PROPERTIES:
:EMAIL: mailto:te...@test.de; [[mailto:n...@test.de]] f...@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.
---
contrib/lisp/org-contacts.el | 83 ++++++++++++++++++++++++++++++++++++--------
5 files changed, 106 insertions(+), 28 deletions(-)
diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el
index 65eeea8..a502674 100644
--- a/contrib/lisp/org-contacts.el
+++ b/contrib/lisp/org-contacts.el
@@ -218,7 +218,7 @@ This overrides `org-email-link-description-format' if set."
org-contacts-db))
(defun org-contacts-filter (&optional name-match tags-match)
- "Search for a contact maching NAME-MATCH and TAGS-MATCH.
+ "Search for a contact matching NAME-MATCH and TAGS-MATCH.
If both match values are nil, return all contacts."
(if (and (null name-match)
(null tags-match))
@@ -426,7 +426,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)
@@ -438,11 +438,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))
", ")))
@@ -459,14 +459,14 @@ A group FOO is composed of contacts with the tag FOO."
;; returned by `org-contacts-filter'.
for contact-name = (car contact)
;; 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
(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))))
@@ -731,11 +731,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)."
@@ -759,8 +760,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))))
@@ -842,19 +843,19 @@ to do our best."
(head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name)))
(concat head
(when email (progn
- (setq emails-list (split-string email "[,;: ]+"))
+ (setq emails-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-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
@@ -903,7 +904,61 @@ 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 key."
+ (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 (chomp linkstring) proplist)))
+ (setq proplist (cons bufferstring proplist))))
+ (cdr (reverse proplist))))
+
+(defun chomp (str)
+ "Chomp leading and tailing whitespace from STR."
+ (while (string-match "\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'" str)
+ (setq str (replace-match "" t t str)))
+ str)
(provide 'org-contacts)
-;; This program is distaributed 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.
--
1.8.2
