From 1b44df7267eba0f2902ec0eaff8dbc2fc6048f06 Mon Sep 17 00:00:00 2001 From: Michael Strey Date: Fri, 26 Apr 2013 12:29:55 +0200 Subject: [PATCH] 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. --- org-contacts.el | 73 +++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 61 insertions(+), 12 deletions(-) diff --git a/org-contacts.el b/org-contacts.el index 626ad7a..eb3fc09 100644 --- a/org-contacts.el +++ b/org-contacts.el @@ -445,11 +445,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 . 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'. 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 . 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)))) @@ -738,11 +738,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 +767,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)))) @@ -849,19 +850,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 @@ -910,7 +911,55 @@ 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 +`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)