master e555446907: Additional query and results attributes in eudcb-macos-contacts.el

[Thomas Fitzsimmons]

branch: master
commit e555446907880280ee3a6c194e13d03f8405bb30
Author: Alexander Adolf <alexander.adolf@condition-alpha.com>
Commit: Thomas Fitzsimmons <fitzsim@fitzsim.org>

    Additional query and results attributes in eudcb-macos-contacts.el
    
    * lisp/net/eudcb-macos-contacts.el: wider set of attributes for
    queries, and in query results
    * lisp/net/eudc-vars.el (eudc-inline-expansion-format): update
    docstring to explain how to use the function eudc-translate-query to
    translate to generic attribute names in the user supplied formatting
    function
    * etc/NEWS: announce wider query/result attribute set
    * doc/misc/eudc.texi: more details on eudcb-mab.el's limitations
---
 doc/misc/eudc.texi               |  11 ++-
 etc/NEWS                         |   6 ++
 lisp/net/eudc-vars.el            |  15 +--
 lisp/net/eudcb-macos-contacts.el | 201 ++++++++++++++++++++++++++++++---------
 4 files changed, 175 insertions(+), 58 deletions(-)

diff --git a/doc/misc/eudc.texi b/doc/misc/eudc.texi
index 7fd5add67e..4c1adf3b0f 100644
--- a/doc/misc/eudc.texi
+++ b/doc/misc/eudc.texi
@@ -423,11 +423,12 @@ all macOS versions since 10.0 (which was released 2001).
 configurations.
 
 @file{eudcb-mab.el} reverse engineers the format of the database file
-used by the macOS Contacts app, and accesses its contents directly.
-While this may promise some performance advantages, it comes at the
-cost of using an undocumented interface.  Hence, users of
-@file{eudcb-mab.el} are recommended to double check the compatibility
-of @file{eudcb-mab.el} before upgrading to a new version of macOS.
+using the external command-line utility named contacts, which needs to
+be installed separately.  While this may promise some performance
+advantages, it comes at the cost of using an undocumented interface.
+Hence, users of @file{eudcb-mab.el} are recommended to double check
+the compatibility of @file{eudcb-mab.el} and the required, external
+command-line utility before upgrading to a new version of macOS.
 @file{eudcb-mab.el} is retained for backwards compatibility with
 existing configurations, and may be removed in a future release.
 
diff --git a/etc/NEWS b/etc/NEWS
index 11189020f1..28a883efc7 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1507,6 +1507,12 @@ EUDC can now contribute email addresses to 
'completion-at-point' by
 adding the new function 'eudc-capf-complete' to
 'completion-at-point-functions' in 'message-mode'.
 
++++
+*** Additional query and results attributes in eudcb-macos-contacts.el
+The EUDC back-end for the macOS Contacts app now provides a wider set
+of attributes to use for queries, and delivers more attributes in
+query results.
+
 ** EWW/SHR
 
 +++
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el
index 59347ccc89..02636c3d70 100644
--- a/lisp/net/eudc-vars.el
+++ b/lisp/net/eudc-vars.el
@@ -214,13 +214,14 @@ used to format the PHRASE, and COMMENT parts, 
respectively.  It
 receives a single argument, which is an alist of
 protocol-specific attributes describing the recipient.  To access
 the alist elements using generic EUDC attribute names, such as
-for example name, or email, use `eudc-translate-attribute-list'.
-The function should return a list, which should contain two
-elements.  If the first element is a string, it will be used as
-the PHRASE part, quoting it if necessary. If the second element
-is a string, it will be used as the COMMENT part, unless it
-contains characters not allowed in the COMMENT part by RFC 5322,
-in which case the COMMENT part will be omitted."
+for example name, or email, use `eudc-translate-query' with
+REVERSE set to t to transform the received attribute alist.  The
+function should return a list, which should contain two elements.
+If the first element is a string, it will be used as the PHRASE
+part, quoting it if necessary. If the second element is a string,
+it will be used as the COMMENT part, unless it contains
+characters not allowed in the COMMENT part by RFC 5322, in which
+case the COMMENT part will be omitted."
   :type '(choice (const :tag "RFC 5322 formatted \"first last <address>\"" nil)
                  (function :tag "RFC 5322 phrase/comment formatting function")
                  (list :tag "Format string (deprecated)"
diff --git a/lisp/net/eudcb-macos-contacts.el b/lisp/net/eudcb-macos-contacts.el
index c02b5689e7..5c7095ae54 100644
--- a/lisp/net/eudcb-macos-contacts.el
+++ b/lisp/net/eudcb-macos-contacts.el
@@ -25,8 +25,17 @@
 ;;    Contacts app on localhost, so no 3rd party tools are needed.
 
 ;;; Usage:
-;;    (require 'eudcb-macos-contacts)
-;;    (eudc-macos-contacts-set-server "localhost")
+;;    To load the library, first `require' it:
+;;
+;;      (require 'eudcb-macos-contacts)
+;;
+;;    In the simplest case then just use:
+;;
+;;      (eudc-macos-contacts-set-server "localhost")
+;;
+;;    When using `eudc-server-hotlist', instead use:
+;;
+;;      (add-to-list 'eudc-server-hotlist '("localhost" . macos-contacts))
 
 ;;; Code:
 
@@ -35,44 +44,139 @@
 
 ;;{{{      Internal cooking
 
-(defvar eudc-macos-contacts-conversion-alist nil)
+(defvar eudc-macos-contacts-attributes-translation-alist
+  '((name      . last_name)
+    (firstname . first_name)
+    (email     . email)
+    (phone     . phone)
+    (title     . job_title)
+    (o         . organization)
+    (ou        . department))
+  "See `eudc-protocol-attributes-translation-alist'.")
+
+(defconst eudc-macos-contacts--unsearchable-attributes
+  '(email phone)
+  "See `eudc-macos-contacts-search-helper'.")
 
 ;; hook ourselves into the EUDC framework
 (eudc-protocol-set 'eudc-query-function
-                  'eudc-macos-contacts-query-internal
-                  'macos-contacts)
+                   'eudc-macos-contacts-query-internal
+                   'macos-contacts)
 (eudc-protocol-set 'eudc-list-attributes-function
-                  nil
-                  'macos-contacts)
-(eudc-protocol-set 'eudc-macos-contacts-conversion-alist
-                  nil
-                  'macos-contacts)
+                   nil
+                   'macos-contacts)
+(eudc-protocol-set 'eudc-protocol-attributes-translation-alist
+                   'eudc-macos-contacts-attributes-translation-alist
+                   'macos-contacts)
 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes
-                  nil
-                  'macos-contacts)
+                   nil
+                   'macos-contacts)
 
-(defun eudc-macos-contacts-search-helper (str)
+(defun eudc-macos-contacts-search-helper (query)
   "Helper function to query the Contacts app via AppleScript.
-Searches for all persons with a case-insensitive substring match
-of STR in any of their name fields (first, middle, or last)."
-  (if (executable-find "osascript")
-      (call-process "osascript" nil t nil
-                   "-e"
-                   (format "
-set results to {}
-tell application \"Address Book\"
-       set pList to every person whose (name contains \"%s\")
-       repeat with pers in pList
-               repeat with emailAddr in emails of pers
-                       set results to results & {name of pers & \":\" & value ¬
-                       of emailAddr & \"\n\"}
-               end repeat
-       end repeat
-       get results as text
-end tell" str))
-    (message (concat "[eudc] Error in macOS Contacts backend: "
-                    "`osascript' executable not found. "
-                    "Is this is a macOS 10.0 or later system?"))))
+Searches for all persons matching QUERY. QUERY is a list of cons
+cells (ATTR . VALUE) where ATTRs should be valid macOS Contacts
+attribute names with space characters replaced by `_' characters.
+Thus, to for instance search for the \"first name\" attribute in
+the Contacts app, the corresponding ATTR would be the symbol
+`first_name'.
+
+Note that due to the way the Contacts app exposes its data via
+AppleScript, the attributes listed in
+`eudc-macos-contacts--unsearchable-attributes' can not be searched
+efficiently.  If and when one of these attributes appears in
+QUERY, it is thus skipped, and the query is composed from the
+other attributes in the QUERY."
+  (let ((crit-idx 0)
+        (query-str (string)))
+    ;; assemble a query string for use in an AppleScript "whose"
+    ;; filter clause; generally, this has the form
+    ;; (ATTR1 contains "VALUE1") and (ATTR2 contains "VALUE2") and ...
+    (dolist (criterion query)
+      (let ((attr (string-replace "_" " " (symbol-name (car criterion))))
+            (term (cdr criterion)))
+        ;; defend against unusable attribute names as they cause
+        ;; AppleScript to emit an error message, which in turn will
+        ;; cause elisp errors during results parsing in
+        ;; `eudc-macos-contacts-query-internal'
+        (if (or (not (rassq (car criterion)
+                            eudc-macos-contacts-attributes-translation-alist))
+                (memq (car criterion)
+                      eudc-macos-contacts--unsearchable-attributes))
+            (message (concat "[eudc] Warning in macOS Contacts backend: "
+                             "can not search in attribute "
+                             (format "\"%s\"; skipping it."  attr)))
+          (progn
+            (when (> crit-idx 0)
+              (setq query-str (concat query-str " and ")))
+            (setq query-str (concat query-str
+                                    (format "(%s contains \"%s\")" attr term)))
+            (setq crit-idx (1+ crit-idx))))))
+    ;; if a useful query string could be assembled, insert it into the
+    ;; AppleScript template, and run the resulting script; results are
+    ;; captured in the current buffer
+    (if (not (string= query-str ""))
+        (if (executable-find "osascript")
+            (call-process "osascript" nil t nil
+                          "-e"
+                          (format "
+on joinLines(theText)
+        if (theText is missing value) or (theText is \"\") then
+                return \"\"
+        else
+                set thePars to paragraphs of theText
+                set result to {}
+                repeat with para in thePars
+                        set result to result & {para & space}
+                end repeat
+                return text 1 thru -2 of (result as text)
+        end if
+end joinLines
+
+on run
+        set results to {}
+        tell application \"Address Book\"
+                set pList to every person whose %s
+                repeat with pers in pList
+                        set pText to ¬
+                                first name of pers & \":\" & ¬
+                                last name of pers & \":\"
+                        if (job title of pers is not missing value) then ¬
+                                set pText to pText ¬
+                                        & my joinLines(job title of pers)
+                        set pText to pText & \":\"
+                        if (department of pers is not missing value) then ¬
+                                set pText to pText ¬
+                                        & my joinLines(department of pers)
+                        set pText to pText & \":\"
+                        if (organization of pers is not missing value) then ¬
+                                set pText to pText ¬
+                                        & my joinLines(organization of pers)
+                        set pText to pText & \":\"
+                        if (count emails of pers) > 0 then
+                                repeat with emailAddr in emails of pers
+                                        set pText to pText & value ¬
+                                                of emailAddr & \",\"
+                                end repeat
+                                set pText to text 1 thru -2 of pText
+                        end if
+                        set pText to pText & \":\"
+                        if (count phones of pers) > 0 then
+                                repeat with phoneNmbr in phones of pers
+                                        set pText to pText & value ¬
+                                                of phoneNmbr & \",\"
+                                end repeat
+                                set pText to text 1 thru -2 of pText
+                        end if
+                        set results to results & {pText & \"\n\"}
+                end repeat
+                get results as text
+        end tell
+end run
+" query-str))
+          (message (concat "[eudc] Error in macOS Contacts backend: "
+                           "`osascript' executable not found. "
+                           "Is this is a macOS 10.0 or later system?"))))))
 
 (defun eudc-macos-contacts-query-internal (query &optional _return-attrs)
   "Query macOS Contacts with QUERY.
@@ -81,24 +185,29 @@ macOS Contacts attribute names.
 RETURN-ATTRS is a list of attributes to return, defaulting to
 `eudc-default-return-attributes'."
   (let ((macos-contacts-buffer (get-buffer-create " *macOS Contacts*"))
-       result)
+        result)
     (with-current-buffer macos-contacts-buffer
       (erase-buffer)
-      (dolist (term query)
-       (eudc-macos-contacts-search-helper (cdr term)))
+      (eudc-macos-contacts-search-helper query)
       (delete-duplicate-lines (point-min) (point-max))
       (goto-char (point-min))
       (while (not (eobp))
-       (if (not (equal (line-beginning-position) (line-end-position)))
-           (let* ((args (split-string (buffer-substring
-                                       (point) (line-end-position))
-                                      ":"))
-                  (name (nth 0 args))
-                  (email (nth 1 args)))
-             (setq result (cons `((name . ,name)
-                                  (email . ,email))
-                                result))))
-       (forward-line))
+        (if (not (equal (line-beginning-position) (line-end-position)))
+            (let ((keys '(first_name last_name job_title department
+                          organization email phone))
+                  record)
+              (dolist (field (split-string (buffer-substring
+                                            (point) (line-end-position))
+                                           ":"))
+                (let ((key (pop keys)))
+                  (unless (string= "" field)
+                    (pcase key
+                      ((or 'email 'phone) (dolist (x (split-string field ","))
+                                            (push (cons key x) record)))
+                      (_ (push (cons key field) record))))))
+              (unless (length= record 0)
+                (push (nreverse record) result))))
+        (forward-line))
       result)))
 
 ;;}}}