diff --git a/doc/misc/eudc.texi b/doc/misc/eudc.texi index 7fd5add67ea..4c1adf3b0ff 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 11189020f18..28a883efc7a 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 59347ccc89a..02636c3d70b 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
\"" 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 c02b5689e79..5c7095ae54f 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))) ;;}}}