From 7042e888454a935a905df4126063f10e330ddfea Mon Sep 17 00:00:00 2001 From: Alexander Adolf Date: Mon, 25 Jul 2022 16:33:11 +0200 Subject: [PATCH 2/2] Use completion-at-point and EUDC for email address completion * lisp/gnus/message.el: remove all ecomplete, and mailabbrev related code; remove all completion UI code; use completion-at-point for email address completion only (message-completion-alist): make EUDC the default provider for email address completion candidates (message-mail-address-snarf-hook): new generic mechanism to capture email addresses into databases used by the user * lisp/net/eudc-capf.el (eudc-capf-message-expand-name): new optional parameters for prefix beginning and end * lisp/net/eudcb-ecomplete.el: new file; ecomplete back-end for EUDC * lisp/net/eudcb-mailabbrev.el: new file; mailabbrev back-end for EUDC --- lisp/gnus/message.el | 252 +++++++++-------------------------- lisp/net/eudc-capf.el | 15 +-- lisp/net/eudcb-ecomplete.el | 110 +++++++++++++++ lisp/net/eudcb-mailabbrev.el | 100 ++++++++++++++ 4 files changed, 278 insertions(+), 199 deletions(-) create mode 100644 lisp/net/eudcb-ecomplete.el create mode 100644 lisp/net/eudcb-mailabbrev.el diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 07abab4396..528053ef8a 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -51,6 +51,7 @@ (require 'yank-media) (require 'mailcap) (require 'sendmail) +(require 'eudc-capf) (autoload 'mailclient-send-it "mailclient") @@ -1385,26 +1386,13 @@ message-send-method-alist PREDICATE returns non-nil. FUNCTION is called with one parameter -- the prefix.") -(defcustom message-mail-alias-type 'abbrev - "What alias expansion type to use in Message buffers. -The default is `abbrev', which uses mailabbrev. `ecomplete' uses -an electric completion mode. nil switches mail aliases off. -This can also be a list of values." - :group 'message - :link '(custom-manual "(message)Mail Aliases") - :type '(choice (const :tag "Use Mailabbrev" abbrev) - (const :tag "Use ecomplete" ecomplete) - (const :tag "No expansion" nil))) - -(defcustom message-self-insert-commands '(self-insert-command) - "List of `self-insert-command's used to trigger ecomplete. -When one of those commands is invoked to enter a character in To or Cc -header, ecomplete will suggest the candidates of recipients (see also -`message-mail-alias-type'). If you use some tool to enter non-ASCII -text and it replaces `self-insert-command' with the other command, e.g. -`egg-self-insert-command', you may want to add it to this list." - :group 'message-various - :type '(repeat function)) +(make-obsolete-variable 'message-mail-alias-type + "use `eudc-server-hotlist' and `message-mail-address-snarf-hook' instead." + "29.1") + +(make-obsolete-variable 'message-self-insert-commands + "now uses `completion-at-point'." + "29.1") (defcustom message-auto-save-directory (if (file-writable-p message-directory) @@ -1813,6 +1801,21 @@ message-sent-hook :group 'message-various :type 'hook) +(defcustom message-mail-address-snarf-hook nil + "Hook run to snarf email addresses. +This hook is run just after the message was sent as mail. + +The functions on this hook are called once for each header line +where email addresses were found. They take a single argument, a +list of cons cells as returned by `mail-header-parse-addresses'. +Each cons cell corresponds to an email address found. The car of +each cons cell contains the email address. When the cons cell +has a cdr, and its value is not nil, it contains the phrase or +comment part as detected by `mail-header-parse-addresses'." + :version "29.1" + :group 'message-various + :type 'hook) + (defvar message-send-coding-system 'binary "Coding system to encode outgoing mail.") @@ -1934,7 +1937,8 @@ message-draft-article (defvar message-mime-part nil) (defvar message-posting-charset nil) (defvar message-inserted-headers nil) -(defvar message-inhibit-ecomplete nil) +(make-obsolete-variable 'message-inhibit-ecomplete 'eudc-server-hotlist + "29.1") ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -2942,9 +2946,7 @@ message-mode-map "C-c C-p" #'message-insert-screenshot "C-a" #'message-beginning-of-line - "TAB" #'message-tab - - "M-n" #'message-display-abbrev) + "TAB" #'message-tab) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -3094,9 +3096,6 @@ message-strip-forbidden-properties "Strip forbidden properties between BEGIN and END, ignoring the third arg. This function is intended to be called from `after-change-functions'. See also `message-forbidden-properties'." - (when (and (message-mail-alias-type-p 'ecomplete) - (memq this-command message-self-insert-commands)) - (message-display-abbrev)) (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) (let ((inhibit-read-only t)) @@ -3174,12 +3173,7 @@ message-mode ;; Mmmm... Forbidden properties... (add-hook 'after-change-functions #'message-strip-forbidden-properties nil 'local) - ;; Allow mail alias things. - (cond - ((message-mail-alias-type-p 'abbrev) - (mail-abbrevs-setup)) - ((message-mail-alias-type-p 'ecomplete) - (ecomplete-setup))) + ;; email address completion uses completion-at-point (add-hook 'completion-at-point-functions #'message-completion-function nil t) (unless buffer-file-name (message-set-auto-save-file-name)) @@ -4440,10 +4434,11 @@ message-send (save-excursion (run-hooks 'message-sent-hook)) (message "Sending...done") - ;; Do ecomplete address snarfing. - (when (and (message-mail-alias-type-p 'ecomplete) - (not message-inhibit-ecomplete)) - (message-put-addresses-in-ecomplete)) + ;; Do address snarfing. + (dolist (header '("to" "cc" "from" "reply-to")) + (let* ((value (message-field-value header)) + (parsed (mail-header-parse-addresses value))) + (run-hook-with-args 'message-mail-address-snarf-hook parsed))) ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) (delete-auto-save-file-if-necessary t) @@ -8017,8 +8012,7 @@ message-resend ;; message has already been encoded. (let ((case-fold-search t)) (re-search-forward "^mime-version:" nil t))) - (message-inhibit-ecomplete t) - ;; We don't want smtpmail.el to encode anything, either. + ;; We don't want smtpmail.el to encode anything, either. (sendmail-coding-system 'raw-text) (select-safe-coding-system-function nil) message-required-mail-headers @@ -8247,7 +8241,7 @@ message-completion-alist :completions ,#'message-expand-group)) (,message-email-recipient-header-regexp . (:category email :fieldsep-re "\\([:,]\\|^\\)[ \t]*" - :completions ,#'message-expand-name))) + :completions ,#'eudc-capf-message-expand-name))) "Alist of (RE . RECIPE), defining completion contexts. This variable controls how `message-completion-function' performs in-buffer completion. RECIPE is either a function (deprecated), @@ -8305,12 +8299,9 @@ message-completion-alist-set-completions message-completion-alist))) nil) -(defcustom message-expand-name-databases - '(bbdb eudc) - "List of databases to try for name completion (`message-expand-name'). -Each element is a symbol and can be `bbdb' or `eudc'." - :group 'message - :type '(set (const bbdb) (const eudc))) +(make-obsolete-variable 'message-expand-name-databases + "use `eudc-server-hotlist' instead." + "29.1") (defcustom message-tab-body-function nil "Function to execute when `message-tab' (TAB) is executed in the body. @@ -8415,97 +8406,19 @@ message-expand-group (when collection (list b e collection)))) -(defcustom message-expand-name-standard-ui nil - "If non-nil, use the standard completion UI in `message-expand-name'. -E.g. this means it will obey `completion-styles' and other such settings. +(make-obsolete-variable 'message-expand-name-standard-ui + "the UI is provided by `completion-at-point'." + "29.1") -If this variable is non-nil and `message-mail-alias-type' is -`ecomplete', `message-self-insert-commands' should probably be -set to nil." - :version "27.1" - :type 'boolean) +(make-obsolete 'message-expand-name 'eudc-capf-expand-name + "29.1") -(defun message-expand-name (&optional pfx-beg pfx-end) - (cond (message-expand-name-standard-ui - (let ((beg (or pfx-beg (save-excursion - (skip-chars-backward "^\n:,") - (skip-chars-forward " \t") - (point)))) - (end (or pfx-end (save-excursion - (skip-chars-forward "^\n,") - (skip-chars-backward " \t") - (point))))) - (when (< beg end) - (list beg end (message--name-table (buffer-substring beg end)))))) - ((and (memq 'eudc message-expand-name-databases) - (boundp 'eudc-protocol) - eudc-protocol) - (eudc-expand-inline)) - ((and (memq 'bbdb message-expand-name-databases) - (fboundp 'bbdb-complete-name)) - (let ((starttick (buffer-modified-tick))) - (or (bbdb-complete-name) - ;; Apparently, bbdb-complete-name can return nil even when - ;; completion took place. So let's double check the buffer was - ;; not modified. - (/= starttick (buffer-modified-tick))))) - (t - (expand-abbrev)))) - -(defun message--bbdb-query-with-words (words) - ;; FIXME: This (or something like this) should live on the BBDB side. - (when (fboundp 'bbdb-records) - (require 'bbdb) ;FIXME: `bbdb-records' is incorrectly autoloaded! - (bbdb-records) ;Make sure BBDB and its database is initialized. - (defvar bbdb-hashtable) - (declare-function bbdb-record-mail "bbdb" (record)) - (declare-function bbdb-dwim-mail "bbdb-com" (record &optional mail)) - (declare-function bbdb-completion-predicate "bbdb-com" (key records)) - (let ((records '()) - (responses '())) - (dolist (word words) - (dolist (c (all-completions word bbdb-hashtable - #'bbdb-completion-predicate)) - (dolist (record (gethash c bbdb-hashtable)) - (cl-pushnew record records)))) - (dolist (record records) - (dolist (mail (bbdb-record-mail record)) - (push (bbdb-dwim-mail record mail) responses))) - responses))) - -(defun message--name-table (orig-string) - (let ((orig-words (split-string orig-string "[ \t]+")) - eudc-responses - bbdb-responses) - (lambda (string pred action) - (pcase action - ('metadata (let* ((recipe (alist-get message-email-recipient-header-regexp - message-completion-alist)) - (cat (plist-get recipe :category))) - (pcase recipe - ((pred functionp) '(metadata (category . email))) - (_ (when cat `(metadata (category . ,cat))))))) - ('lambda t) - ((or 'nil 't) - (when orig-words - (when (and (memq 'eudc message-expand-name-databases) - (boundp 'eudc-protocol) - eudc-protocol) - (setq eudc-responses (eudc-query-with-words orig-words))) - (when (memq 'bbdb message-expand-name-databases) - (setq bbdb-responses (message--bbdb-query-with-words orig-words))) - (ecomplete-setup) - (setq orig-words nil)) - (let ((candidates - ;; FIXME: Add `expand-abbrev'! - (append (all-completions string eudc-responses pred) - (all-completions string bbdb-responses pred) - (when (and (bound-and-true-p ecomplete-database) - (fboundp 'ecomplete-completion-table)) - (all-completions string - (ecomplete-completion-table 'mail) - pred))))) - (if action candidates (try-completion string candidates)))))))) +(make-obsolete 'message--bbdb-query-with-words + "use `eudc-server-hotlist' instead." + "29.1") + +(make-obsolete 'message--name-table 'eudc-capf-expand-name + "29.1") ;;; Help stuff. @@ -8708,62 +8621,19 @@ message-hide-header-p (not result) result))) -(declare-function ecomplete-add-item "ecomplete" (type key text)) -(declare-function ecomplete-save "ecomplete" ()) - -(defun message-put-addresses-in-ecomplete () - (require 'ecomplete) - (dolist (header '("to" "cc" "from" "reply-to")) - (let ((value (message-field-value header))) - (dolist (string (mail-header-parse-addresses value 'raw)) - (setq string - (string-replace - "\n" "" - (replace-regexp-in-string "^ +\\| +$" "" string))) - (ecomplete-add-item 'mail (car (mail-header-parse-address string)) - string)))) - (ecomplete-save)) - -(autoload 'ecomplete-display-matches "ecomplete") - -(defun message--in-tocc-p () - (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) - (message-point-in-header-p) - (save-excursion - (beginning-of-line) - (while (and (memq (char-after) '(?\t ? )) - (zerop (forward-line -1)))) - (looking-at "To:\\|Cc:")))) - -(defun message-display-abbrev (&optional choose) - "Display the next possible abbrev for the text before point." - (interactive (list t) message-mode) - (when (message--in-tocc-p) - (let* ((end (point)) - (start (save-excursion - (and (re-search-backward "[\n\t ]" nil t) - (1+ (point))))) - (word (when start (buffer-substring start end))) - (match (when (and word - (not (zerop (length word)))) - (ecomplete-display-matches 'mail word choose)))) - (when (and choose match) - (delete-region start end) - (insert match))))) - -(defun message-ecomplete-capf () - "Return completion data for email addresses in Ecomplete. -Meant for use on `completion-at-point-functions'." - (when (and (bound-and-true-p ecomplete-database) - (fboundp 'ecomplete-completion-table) - (message--in-tocc-p)) - (let ((end (save-excursion - (skip-chars-forward "^, \t\n") - (point))) - (start (save-excursion - (skip-chars-backward "^, \t\n") - (point)))) - `(,start ,end ,(ecomplete-completion-table 'mail))))) +(make-obsolete 'message-put-addresses-in-ecomplete 'message-mail-address-snarf-hook + "29.1") + +(make-obsolete 'message--in-tocc-p 'message-completion-function + "29.1") + +(make-obsolete 'message-display-abbrev + "now uses `completion-at-point'." + "29.1") + +(make-obsolete 'message-ecomplete-capf + "use `eudcb-ecomplete' in `eudc-server-hotlist' instead." + "29.1") ;; To send pre-formatted letters like the example below, you can use ;; `message-send-form-letter': diff --git a/lisp/net/eudc-capf.el b/lisp/net/eudc-capf.el index 92f0c80493..884d6e371f 100644 --- a/lisp/net/eudc-capf.el +++ b/lisp/net/eudc-capf.el @@ -107,21 +107,20 @@ eudc-capf-complete (eudc-capf-message-expand-name))) ;;;###autoload -(defun eudc-capf-message-expand-name () +(defun eudc-capf-message-expand-name (&optional pfx-beg pfx-end) "Email address completion function for `message-completion-alist'. -When this function is added to `message-completion-alist', -replacing any existing entry for `message-expand-name' there, -with an appropriate regular expression such as for example +When this function is added to `message-completion-alist', with +an appropriate regular expression such as for example `message-email-recipient-header-regexp', then EUDC will be queried for email addresses, and the results delivered to `completion-at-point'." (if (or eudc-server eudc-server-hotlist) (progn - (let* ((beg (save-excursion - (re-search-backward "\\([:,]\\|^\\)[ \t]*") - (match-end 0))) - (end (point)) + (let* ((beg (or pfx-beg (save-excursion + (re-search-backward "\\([:,]\\|^\\)[ \t]*") + (match-end 0)))) + (end (or pfx-end (point))) (prefix (save-excursion (buffer-substring-no-properties beg end)))) (list beg end (completion-table-with-cache diff --git a/lisp/net/eudcb-ecomplete.el b/lisp/net/eudcb-ecomplete.el new file mode 100644 index 0000000000..6d12ab9231 --- /dev/null +++ b/lisp/net/eudcb-ecomplete.el @@ -0,0 +1,110 @@ +;;; eudcb-ecomplete.el --- EUDC - ecomplete backend -*- lexical-binding: t -*- + +;; Copyright (C) 2022 condition-alpha.com + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; 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. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; This library provides an interface to the ecomplete package as +;; an EUDC data source. + +;;; Usage: +;; To load the library, first `require' it: +;; +;; (require 'eudcb-ecomplete) +;; +;; In the simplest case then just use: +;; +;; (eudc-ecomplete-set-server "localhost") +;; +;; When using `eudc-server-hotlist', instead use: +;; +;; (add-to-list 'eudc-server-hotlist '("localhost" . ecomplete)) + +;;; Code: + +(require 'eudc) +(require 'ecomplete) +(require 'mail-parse) + +(defvar eudc-ecomplete-attributes-translation-alist + '((email . mail)) + "See `eudc-protocol-attributes-translation-alist'. +The back-end-specific attribute names are used as the \"type\" of +entry when searching, and they must hence match the types you use +in your ecmompleterc database file.") + +;; hook ourselves into the EUDC framework +(eudc-protocol-set 'eudc-query-function + 'eudc-ecomplete-query-internal + 'ecomplete) +(eudc-protocol-set 'eudc-list-attributes-function + nil + 'ecomplete) +(eudc-protocol-set 'eudc-protocol-attributes-translation-alist + 'eudc-ecomplete-attributes-translation-alist + 'ecomplete) +(eudc-protocol-set 'eudc-protocol-has-default-query-attributes + nil + 'ecomplete) + +(defun eudc-ecomplete-query-internal (query &optional _return-attrs) + "Query `ecomplete' with QUERY. +QUERY is a list of cons cells (ATTR . VALUE). Since `ecomplete' +does not provide attributes in the usual sense, the +back-end-specific attribute names in +`eudc-ecomplete-attributes-translation-alist' are used as the +KEY (that is, the \"type\" of match) when looking for matches in +`ecomplete-database'. + +RETURN-ATTRS is a list of attributes to return, defaulting to +`eudc-default-return-attributes'." + (ecomplete-setup) + (let ((email-attr (car (eudc-translate-attribute-list '(email)))) + result) + (dolist (term query) + (let* ((attr (car term)) + (value (cdr term)) + (matches (ecomplete-get-matches attr value))) + (when matches + (dolist (match (split-string (string-trim (substring-no-properties + matches)) + "[\n\r]")) + ;; special case email: try to decompose + (let* ((decoded (mail-header-parse-address match t)) + (name (cdr decoded)) + (email (car decoded))) + (if (and decoded (eq attr email-attr)) + ;; email could be decomposed, push individual fields + (push `((,attr . ,email) + ,@(when name (list (cons 'name name)))) + result) + ;; else, just forward the value as-is + (push (list (cons attr match)) result))))))) + result)) + +(defun eudc-ecomplete-set-server (dummy) + "Set the EUDC server to `ecomplete'. +The server in DUMMY is not actually used, since this backend +always and implicitly uses the ecomplete package in the current +Emacs instance running on the local host." + (interactive) + (eudc-set-server dummy 'ecomplete) + (message "[eudc] ecomplete server selected")) + +(eudc-register-protocol 'ecomplete) + +(provide 'eudcb-ecomplete) + +;;; eudcb-ecomplete.el ends here diff --git a/lisp/net/eudcb-mailabbrev.el b/lisp/net/eudcb-mailabbrev.el new file mode 100644 index 0000000000..816ce7b1e9 --- /dev/null +++ b/lisp/net/eudcb-mailabbrev.el @@ -0,0 +1,100 @@ +;;; eudcb-mailabbrev.el --- EUDC - mailabbrev backend -*- lexical-binding: t -*- + +;; Copyright (C) 2022 condition-alpha.com + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; 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. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; This library provides an interface to the mailabbrev package as +;; an EUDC data source. + +;;; Usage: +;; To load the library, first `require' it: +;; +;; (require 'eudcb-mailabbrev) +;; +;; In the simplest case then just use: +;; +;; (eudc-mailabbrev-set-server "localhost") +;; +;; When using `eudc-server-hotlist', instead use: +;; +;; (add-to-list 'eudc-server-hotlist '("localhost" . mailabbrev)) + +;;; Code: + +(require 'eudc) +(require 'mailabbrev) +(require 'mail-parse) + +;; hook ourselves into the EUDC framework +(eudc-protocol-set 'eudc-query-function + 'eudc-mailabbrev-query-internal + 'mailabbrev) +(eudc-protocol-set 'eudc-list-attributes-function + nil + 'mailabbrev) +(eudc-protocol-set 'eudc-protocol-attributes-translation-alist + nil + 'mailabbrev) +(eudc-protocol-set 'eudc-protocol-has-default-query-attributes + nil + 'mailabbrev) + +(defun eudc-mailabbrev-query-internal (query &optional _return-attrs) + "Query `mailabbrev' with QUERY. +QUERY is a list of cons cells (ATTR . VALUE). Since `mailabbrev' +does not provide attributes in the usual sense, the +back-end-specific attribute names in +`eudc-mailabbrev-attributes-translation-alist' are used as the +KEY (that is, the \"type\" of match) when looking for matches in +`mailabbrev-database'. + +RETURN-ATTRS is a list of attributes to return, defaulting to +`eudc-default-return-attributes'." + (mail-abbrevs-setup) + (let (result) + (dolist (term query) + (let* ((attr (car term)) + (value (cdr term)) + (match (symbol-value (intern-soft value mail-abbrevs)))) + (when (and match + (memq attr '(email firstname name))) + ;; try to decompose email construct + (let* ((decoded (mail-header-parse-address match t)) + (name (cdr decoded)) + (email (car decoded))) + (if decoded + ;; decoding worked, push individual fields + (push `((email . ,email) + ,@(when name (list (cons 'name name)))) + result) + ;; else, just forward the value as-is + (push (list (cons 'email match)) result)))))) + result)) + +(defun eudc-mailabbrev-set-server (dummy) + "Set the EUDC server to `mailabbrev'. +The server in DUMMY is not actually used, since this backend +always and implicitly uses the mailabbrev package in the current +Emacs instance running on the local host." + (interactive) + (eudc-set-server dummy 'mailabbrev) + (message "[eudc] mailabbrev server selected")) + +(eudc-register-protocol 'mailabbrev) + +(provide 'eudcb-mailabbrev) + +;;; eudcb-mailabbrev.el ends here -- 2.37.1