[Emacs-diffs] /srv/bzr/emacs/trunk r103925: Use completion-at-point for mailalias.el

[Stefan Monnier]

------------------------------------------------------------
revno: 103925
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Fri 2011-04-15 10:50:04 -0300
message:
  Use completion-at-point for mailalias.el
  * lisp/mail/mailalias.el: Use lexical-binding.
  (pattern, mailalias-done): Declare dynamic.
  (mail-completion-at-point-function): New function, from mail-complete.
  (mail-complete): Use it.
  (mail-completion-expand): New function.
  (mail-get-names): Use it.
  (mail-directory, mail-directory-process, mail-directory-stream):
  Don't use `pattern' for lexically bound arg.
  * lisp/mail/sendmail.el (mail-mode-map): Use completion-at-point.
  (mail-mode): Setup mailalias completion here instead.
modified:
  lisp/ChangeLog
  lisp/mail/mailalias.el
  lisp/mail/sendmail.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2011-04-15 12:57:53 +0000
+++ b/lisp/ChangeLog    2011-04-15 13:50:04 +0000
@@ -1,5 +1,16 @@
 2011-04-15  Stefan Monnier  <address@hidden>
 
+       * mail/sendmail.el (mail-mode-map): Use completion-at-point.
+       (mail-mode): Setup mailalias completion here instead.
+       * mail/mailalias.el: Use lexical-binding.
+       (pattern, mailalias-done): Declare dynamic.
+       (mail-completion-at-point-function): New function, from mail-complete.
+       (mail-complete): Use it.
+       (mail-completion-expand): New function.
+       (mail-get-names): Use it.
+       (mail-directory, mail-directory-process, mail-directory-stream):
+       Don't use `pattern' for lexically bound arg.
+
        * emacs-lisp/lisp-mode.el (eval-defun-2): Use eval-sexp-add-defvars.
 
        * htmlfontify.el (hfy-etags-cmd): Remove inoperant eval-and-compile.
@@ -89,8 +100,8 @@
 
        * minibuffer.el (completion-show-inline-help): New var.
        (completion--do-completion, minibuffer-complete)
-       (minibuffer-force-complete, minibuffer-complete-word): Inhibit
-       minibuffer messages if completion-show-inline-help is nil.
+       (minibuffer-force-complete, minibuffer-complete-word):
+       Inhibit minibuffer messages if completion-show-inline-help is nil.
 
        * icomplete.el (icomplete-mode): Bind completion-show-inline-help
        to avoid interference from inline help (Bug#5849).
@@ -106,7 +117,7 @@
        not in Image mode.
        (image-transform-mode, image-transform-resize)
        (image-transform-set-rotation): Doc fix.
-       (image-transform-set-resize): Deleted.
+       (image-transform-set-resize): Delete.
        (image-transform-set-scale, image-transform-fit-to-height)
        (image-transform-fit-to-width): Handle image-toggle-display-image
        and image-transform-resize directly.
@@ -196,7 +207,7 @@
        (package-menu--generate): Use package--push.  Renamed from
        package--generate-package-list.
        (package-menu-refresh, list-packages): Use it.
-       (package-menu--print-info): Renamed from package-print-package.
+       (package-menu--print-info): Rename from package-print-package.
        Return insertion data instead of inserting it directly.
        (package-menu-describe-package, package-menu-execute):
        Use tabulated-list-get-id.
@@ -313,8 +324,8 @@
        * dired-aux.el (dired-create-files): Add docstring (Bug#7970).
 
        * textmodes/flyspell.el (flyspell-word): Recognize default
-       dictionary case for flyspell-mark-duplications-exceptions.  Use
-       regexp matching for languages.
+       dictionary case for flyspell-mark-duplications-exceptions.
+       Use regexp matching for languages.
        (flyspell-mark-duplications-exceptions): Add "that" and "had" for
        default dictionary (Bug#7926).
 

=== modified file 'lisp/mail/mailalias.el'
--- a/lisp/mail/mailalias.el    2011-01-25 04:08:28 +0000
+++ b/lisp/mail/mailalias.el    2011-04-15 13:50:04 +0000
@@ -1,4 +1,4 @@
-;;; mailalias.el --- expand and complete mailing address aliases
+;;; mailalias.el --- expand and complete mailing address aliases -*- 
lexical-binding: t -*-
 
 ;; Copyright (C) 1985, 1987, 1995-1997, 2001-2011
 ;;   Free Software Foundation, Inc.
@@ -52,20 +52,20 @@
 (defvar mail-address-field-regexp
   "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):")
 
+(defvar pattern)
+
 (defcustom mail-complete-alist
-  ;; Don't use backquote here; we don't want backquote to get loaded
-  ;; just because of loading this file.
   ;; Don't refer to mail-address-field-regexp here;
   ;; that confuses some things such as cus-dep.el.
-  (cons '("^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):"
-         . (mail-get-names pattern))
-       '(("Newsgroups:" . (if (boundp 'gnus-active-hashtb)
-                              gnus-active-hashtb
-                            (if (boundp news-group-article-assoc)
-                                news-group-article-assoc)))
-         ("Followup-To:" . (mail-sentto-newsgroups))
-         ;;("Distribution:" ???)
-         ))
+  '(("^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):"
+     . (mail-get-names pattern))
+    ("Newsgroups:" . (if (boundp 'gnus-active-hashtb)
+                         gnus-active-hashtb
+                       (if (boundp news-group-article-assoc)
+                           news-group-article-assoc)))
+    ("Followup-To:" . (mail-sentto-newsgroups))
+    ;;("Distribution:" ???)
+    )
   "Alist of header field and expression to return alist for completion.
 The expression may reference the variable `pattern'
 which will hold the string being completed.
@@ -90,6 +90,8 @@
   "Function to call when completing outside `mail-complete-alist'-header."
   :type '(choice function (const nil))
   :group 'mailalias)
+(make-obsolete-variable 'mail-complete-function
+                        'completion-at-point-functions "24.1")
 
 (defcustom mail-directory-function nil
   "Function to get completions from directory service or nil for none.
@@ -390,11 +392,9 @@
            mail-names t))))
 
 ;;;###autoload
-(defun mail-complete (arg)
-  "Perform completion on header field or word preceding point.
-Completable headers are according to `mail-complete-alist'.  If none matches
-current header, calls `mail-complete-function' and passes prefix arg if any."
-  (interactive "P")
+(defun mail-completion-at-point-function ()
+  "Compute completion data for mail aliases.
+For use on `completion-at-point-functions'."
   ;; Read the defaults first, if we have not done so.
   (sendmail-sync-aliases)
   (if (eq mail-aliases t)
@@ -402,52 +402,70 @@
        (setq mail-aliases nil)
        (if (file-exists-p mail-personal-alias-file)
            (build-mail-aliases))))
-  (let ((list mail-complete-alist))
+  (let ((list mail-complete-alist)
+        (list-exp nil))
     (if (and (< 0 (mail-header-end))
             (save-excursion
-              (if (re-search-backward "^[^\t]" nil t)
+              (if (re-search-backward "^[^\t ]" nil t)
                   (while list
                     (if (looking-at (car (car list)))
-                        (setq arg (cdr (car list))
+                        (setq list-exp (cdr (car list))
                               list ())
                       (setq list (cdr list)))))
-              arg))
+              list-exp))
        (let* ((end (point))
               (beg (save-excursion
                      (skip-chars-backward "^ \t<,:")
                      (point)))
-              (pattern (buffer-substring beg end))
-              completion)
-         (setq list (eval arg)
-               completion (try-completion pattern list))
-         (cond ((eq completion t))
-               ((null completion)
-                (message "Can't find completion for \"%s\"" pattern)
-                (ding))
-               ((not (string= pattern completion))
-                (delete-region beg end)
-                (let ((alist-elt (assoc completion mail-names)))
-                  (if (cdr alist-elt)
-                      (cond ((eq mail-complete-style 'parens)
-                             (insert completion " (" (cdr alist-elt) ")"))
-                            ((eq mail-complete-style 'angles)
-                             (insert (cdr alist-elt) " <" completion ">"))
-                            (t
-                             (insert completion)))
-                    (insert completion))))
-               (t
-                (message "Making completion list...")
-                (with-output-to-temp-buffer "*Completions*"
-                  (display-completion-list
-                   (all-completions pattern list)))
-                (message "Making completion list...%s" "done"))))
+               (table (completion-table-dynamic
+                       (lambda (prefix)
+                         (let ((pattern prefix)) (eval list-exp))))))
+          (list beg end table)))))
+
+;;;###autoload
+(defun mail-complete (arg)
+  "Perform completion on header field or word preceding point.
+Completable headers are according to `mail-complete-alist'.  If none matches
+current header, calls `mail-complete-function' and passes prefix ARG if any."
+  (interactive "P")
+  ;; Read the defaults first, if we have not done so.
+  (sendmail-sync-aliases)
+  (if (eq mail-aliases t)
+      (progn
+       (setq mail-aliases nil)
+       (if (file-exists-p mail-personal-alias-file)
+           (build-mail-aliases))))
+  (let ((data (mail-completion-at-point-function)))
+    (if data
+        (apply #'completion-in-region data)
       (funcall mail-complete-function arg))))
-
-(defun mail-get-names (pattern)
+(make-obsolete 'mail-complete 'mail-completion-at-point-function "24.1")
+
+(defun mail-completion-expand (table)
+  "Build new completion table that expands aliases.
+Completes like TABLE except that if the completion is a valid alias,
+it expands it to its full `mail-complete-style' form."
+  (lambda (string pred action)
+    (cond
+     ((eq action nil)
+      (let* ((comp (try-completion string table pred))
+             (name (and (listp table) comp
+                        (assoc (if (stringp comp) comp string) table))))
+        (cond
+         ((null name) comp)
+         ((eq mail-complete-style 'parens)
+          (concat (car name) " (" (cdr name) ")"))
+         ((eq mail-complete-style 'angles)
+          (concat (cdr name) " <" (car name) ">"))
+         (t comp))))
+     (t
+      (complete-with-action action table string pred)))))
+
+(defun mail-get-names (prefix)
   "Fetch local users and global mail addresses for completion.
 Consults `/etc/passwd' and a directory service if one is set up via
 `mail-directory-function'.
-PATTERN is the string we want to complete."
+PREFIX is the string we want to complete."
   (if (eq mail-local-names t)
       (with-current-buffer (generate-new-buffer " passwd")
        (let ((files mail-passwd-files))
@@ -480,7 +498,7 @@
        (and mail-directory-function
             (eq mail-directory-names t)
             (setq directory
-                  (mail-directory (if mail-directory-requery pattern))))
+                  (mail-directory (if mail-directory-requery prefix))))
        (or mail-directory-requery
            (setq mail-directory-names directory))
        (if (or directory
@@ -496,58 +514,59 @@
                                    (when (consp mail-directory-names)
                                      mail-directory-names)))
                        (lambda (a b)
-                         ;; should cache downcased strings
+                         ;; Should cache downcased strings.
                          (string< (downcase (car a))
                                   (downcase (car b)))))))))
-  mail-names)
-
-
-(defun mail-directory (pattern)
-  "Use mail-directory facility to get user names matching PATTERN.
-If PATTERN is nil, get all the defined user names.
+  (mail-completion-expand mail-names))
+
+
+(defun mail-directory (prefix)
+  "Use mail-directory facility to get user names matching PREFIX.
+If PREFIX is nil, get all the defined user names.
 This function calls `mail-directory-function' to query the directory,
 then uses `mail-directory-parser' to parse the output it returns."
   (message "Querying directory...")
   (with-current-buffer (generate-new-buffer " *mail-directory*")
-    (funcall mail-directory-function pattern)
+    (funcall mail-directory-function prefix)
     (goto-char (point-min))
     (let (directory)
       (if (stringp mail-directory-parser)
          (while (re-search-forward mail-directory-parser nil t)
-           (setq directory
-                 (cons (match-string 1) directory)))
+           (push (match-string 1) directory))
        (if mail-directory-parser
            (setq directory (funcall mail-directory-parser))
          (while (not (eobp))
-           (setq directory
-                 (cons (buffer-substring (point)
-                                         (progn
-                                           (forward-line)
-                                           (if (bolp)
-                                               (1- (point))
-                                             (point))))
-                       directory)))))
+           (push (buffer-substring (point)
+                                    (progn
+                                      (forward-line)
+                                      (if (bolp)
+                                          (1- (point))
+                                        (point))))
+                  directory))))
       (kill-buffer (current-buffer))
       (message "Querying directory...done")
       directory)))
 
+(defvar mailalias-done)
 
-(defun mail-directory-process (pattern)
+(defun mail-directory-process (prefix)
   "Run a shell command to output names in directory.
 See `mail-directory-process'."
   (when (consp mail-directory-process)
-    (apply 'call-process (eval (car mail-directory-process)) nil t nil
-          (mapcar 'eval (cdr mail-directory-process)))))
+    (let ((pattern prefix))             ;Dynbind!
+      (apply 'call-process (eval (car mail-directory-process)) nil t nil
+             (mapcar 'eval (cdr mail-directory-process))))))
 
 ;; This should handle a dialog.  Currently expects port to spit out names.
-(defun mail-directory-stream (pattern)
+(defun mail-directory-stream (prefix)
   "Open a stream to retrieve names in directory.
 See `mail-directory-stream'."
-  (let (mailalias-done)
+  (let ((mailalias-done nil)
+        (pattern prefix))               ;Dynbind!
     (set-process-sentinel
      (apply 'open-network-stream "mailalias" (current-buffer)
            mail-directory-stream)
-     (lambda (x y)
+     (lambda (_x _y)
        (setq mailalias-done t)))
     (while (not mailalias-done)
       (sit-for .1))))

=== modified file 'lisp/mail/sendmail.el'
--- a/lisp/mail/sendmail.el     2011-03-03 07:08:22 +0000
+++ b/lisp/mail/sendmail.el     2011-04-15 13:50:04 +0000
@@ -293,7 +293,7 @@
 (defvar mail-abbrevs-loaded nil)
 (defvar mail-mode-map
   (let ((map (make-sparse-keymap)))
-    (define-key map "\M-\t" 'mail-complete)
+    (define-key map "\M-\t" 'completion-at-point)
     (define-key map "\C-c?" 'describe-mode)
     (define-key map "\C-c\C-f\C-t" 'mail-to)
     (define-key map "\C-c\C-f\C-b" 'mail-bcc)
@@ -688,6 +688,8 @@
   (setq adaptive-fill-first-line-regexp
        (concat "[ \t]*[-[:alnum:]]*>+[ \t]*\\|"
                adaptive-fill-first-line-regexp))
+  (add-hook 'completion-at-point-functions #'mail-completion-at-point-function
+            nil 'local)
   ;; `-- ' precedes the signature.  `-----' appears at the start of the
   ;; lines that delimit forwarded messages.
   ;; Lines containing just >= 3 dashes, perhaps after whitespace,