X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b1fc2b501450661ba452bea0df677a08cf00368b..ae0d461554a9351a0d897ce0e60b47fc9670431e:/lisp/mail/mailalias.el

diff --git a/lisp/mail/mailalias.el b/lisp/mail/mailalias.el
index 0ccb1b4d93..c5f1e3921f 100644
--- a/lisp/mail/mailalias.el
+++ b/lisp/mail/mailalias.el
@@ -1,7 +1,7 @@
-;;; mailalias.el --- expand and complete mailing address aliases
+;;; mailalias.el --- expand and complete mailing address aliases -*- lexical-binding: t -*-
 
-;; Copyright (C) 1985, 1987, 1995, 1996, 1997, 2001, 2002, 2003,
-;;   2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1995-1997, 2001-2013 Free Software
+;; Foundation, Inc.
 
 ;; Maintainer: FSF
 ;; Keywords: mail
@@ -36,12 +36,12 @@
   :group 'mail)
 
 (defcustom mail-passwd-files '("/etc/passwd")
-  "*List of files from which to determine valid user names."
+  "List of files from which to determine valid user names."
   :type '(repeat string)
   :group 'mailalias)
 
 (defcustom mail-passwd-command nil
-  "*Shell command to retrieve text to add to `/etc/passwd', or nil."
+  "Shell command to retrieve text to add to `/etc/passwd', or nil."
   :type '(choice string (const nil))
   :group 'mailalias)
 
@@ -52,21 +52,21 @@ When t this still needs to be initialized.")
 (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:" ???)
-	  ))
-  "*Alist of header field and expression to return alist for completion.
+  '(("^\\(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.
 If not on matching header, `mail-complete-function' gets called instead."
@@ -76,7 +76,7 @@ If not on matching header, `mail-complete-function' gets called instead."
 
 ;;;###autoload
 (defcustom mail-complete-style 'angles
-  "*Specifies how \\[mail-complete] formats the full name when it completes.
+  "Specifies how \\[mail-complete] formats the full name when it completes.
 If `nil', they contain just the return address like:
 	king@grassland.com
 If `parens', they look like:
@@ -87,26 +87,28 @@ If `angles', they look like:
   :group 'mailalias)
 
 (defcustom mail-complete-function 'ispell-complete-word
-  "*Function to call when completing outside `mail-complete-alist'-header."
+  "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.
+  "Function to get completions from directory service or nil for none.
 See `mail-directory-requery'."
   :type '(choice function (const nil))
   :group 'mailalias)
 
 ;; This is for when the directory is huge, or changes frequently.
 (defcustom mail-directory-requery nil
-  "*When non-nil call `mail-directory-function' for each completion.
+  "When non-nil call `mail-directory-function' for each completion.
 In that case, one argument gets passed to the function, the partial string
 entered so far."
   :type 'boolean
   :group 'mailalias)
 
 (defcustom mail-directory-process nil
-  "*Shell command to get the list of names from a mail directory.
+  "Shell command to get the list of names from a mail directory.
 This value is used when the value of `mail-directory-function'
 is `mail-directory-process'.  The value should be a list
 of the form (COMMAND ARG ...), where each of the list elements
@@ -127,13 +129,13 @@ or like this:
 (put 'mail-directory-process 'risky-local-variable t)
 
 (defcustom mail-directory-stream nil
-  "*List of (HOST SERVICE) for stream connection to mail directory."
+  "List of (HOST SERVICE) for stream connection to mail directory."
   :type 'sexp
   :group 'mailalias)
 (put 'mail-directory-stream 'risky-local-variable t)
 
 (defcustom mail-directory-parser nil
-  "*How to interpret the output of `mail-directory-function'.
+  "How to interpret the output of `mail-directory-function'.
 Three types of values are possible:
 
   - nil means to gather each line as one name
@@ -240,68 +242,66 @@ removed from alias expansions."
 (defun build-mail-aliases (&optional file)
   "Read mail aliases from personal aliases file and set `mail-aliases'.
 By default, this is the file specified by `mail-personal-alias-file'."
+  (interactive
+   (list
+    (read-file-name (format "Read mail alias file (default %s): "
+			    mail-personal-alias-file)
+		    nil mail-personal-alias-file t)))
   (setq file (expand-file-name (or file mail-personal-alias-file)))
   ;; In case mail-aliases is t, make sure define-mail-alias
   ;; does not recursively call build-mail-aliases.
   (setq mail-aliases nil)
-  (let ((buffer nil)
-	(obuf (current-buffer)))
-    (unwind-protect
-	(progn
-	  (setq buffer (generate-new-buffer " mailrc"))
-	  (set-buffer buffer)
-	  (while file
-	    (cond ((get-file-buffer file)
-		   (insert (save-excursion
-			     (set-buffer (get-file-buffer file))
-			     (buffer-substring-no-properties
-			      (point-min) (point-max)))))
-		  ((file-exists-p file) (insert-file-contents file))
-		  ((file-exists-p (setq file (concat "~/" file)))
-		   (insert-file-contents file))
-		  (t (setq file nil)))
-	    (goto-char (point-min))
-	    ;; Delete comments from the contents.
-	    (while (search-forward "# " nil t)
-	      (let ((p (- (point) 2)))
-		(end-of-line)
-		(delete-region p (point))))
-	    ;; Don't lose if no final newline.
-	    (goto-char (point-max))
-	    (or (eq (preceding-char) ?\n) (newline))
-	    (goto-char (point-min))
-	    ;; handle "\\\n" continuation lines
-	    (while (not (eobp))
-	      (end-of-line)
-	      (if (= (preceding-char) ?\\)
-		  (progn (delete-char -1) (delete-char 1) (insert ?\ ))
-	        (forward-char 1)))
-	    (goto-char (point-min))
-	    ;; handle `source' directives -- Eddy/1994/May/25
-	    (cond ((re-search-forward "^source[ \t]+" nil t)
-		   (re-search-forward "\\S-+")
-		   (setq file (buffer-substring-no-properties
-			       (match-beginning 0) (match-end 0)))
-		   (beginning-of-line)
-		   (insert "# ") ; to ensure we don't re-process this file
-		   (beginning-of-line))
-		  (t (setq file nil))))
-	  (goto-char (point-min))
-	  (while (re-search-forward
-		  "^\\(a\\|alias\\|g\\|group\\)[ \t]+\\([^ \t\n]+\\)" nil t)
-	    (let* ((name (match-string 2))
-		   (start (progn (skip-chars-forward " \t") (point)))
-		   value)
-	      (end-of-line)
-	      (setq value (buffer-substring-no-properties start (point)))
-	      (unless (equal value "")
-		(define-mail-alias name value t))))
-	  mail-aliases)
-      (if buffer (kill-buffer buffer))
-      (set-buffer obuf))))
+  (with-temp-buffer
+    (while file
+      (cond ((get-file-buffer file)
+             (insert (with-current-buffer (get-file-buffer file)
+                       (buffer-substring-no-properties
+                        (point-min) (point-max)))))
+            ((file-exists-p file) (insert-file-contents file))
+            ((file-exists-p (setq file (expand-file-name file "~/")))
+             (insert-file-contents file))
+            (t (setq file nil)))
+      (goto-char (point-min))
+      ;; Delete comments from the contents.
+      (while (search-forward "# " nil t)
+        (let ((p (- (point) 2)))
+          (end-of-line)
+          (delete-region p (point))))
+      ;; Don't lose if no final newline.
+      (goto-char (point-max))
+      (or (eq (preceding-char) ?\n) (newline))
+      (goto-char (point-min))
+      ;; handle "\\\n" continuation lines
+      (while (not (eobp))
+        (end-of-line)
+        (if (= (preceding-char) ?\\)
+            (progn (delete-char -1) (delete-char 1) (insert ?\ ))
+          (forward-char 1)))
+      (goto-char (point-min))
+      ;; handle `source' directives -- Eddy/1994/May/25
+      (cond ((re-search-forward "^source[ \t]+" nil t)
+             (re-search-forward "\\S-+")
+             (setq file (buffer-substring-no-properties
+                         (match-beginning 0) (match-end 0)))
+             (beginning-of-line)
+             (insert "# ")   ; to ensure we don't re-process this file
+             (beginning-of-line))
+            (t (setq file nil))))
+    (goto-char (point-min))
+    (while (re-search-forward
+            "^\\(a\\|alias\\|g\\|group\\)[ \t]+\\([^ \t\n]+\\)" nil t)
+      (let* ((name (match-string 2))
+             (start (progn (skip-chars-forward " \t") (point)))
+             value)
+        (end-of-line)
+        (setq value (buffer-substring-no-properties start (point)))
+        (unless (equal value "")
+          (define-mail-alias name value t))))
+    mail-aliases))
 
 ;; Always autoloadable in case the user wants to define aliases
 ;; interactively or in .emacs.
+;; define-mail-abbrev in mailabbrev.el duplicates much of this code.
 ;;;###autoload
 (defun define-mail-alias (name definition &optional from-mailrc-file)
   "Define NAME as a mail alias that translates to DEFINITION.
@@ -327,44 +327,64 @@ if it is quoted with double-quotes."
       (setq definition (substring definition (match-end 0))))
   (if (string-match "[ \t\n,]+\\'" definition)
       (setq definition (substring definition 0 (match-beginning 0))))
-  (let ((result '())
-	;; If DEFINITION is null string, avoid looping even once.
-	(start (and (not (equal definition "")) 0))
-	(L (length definition))
-	convert-backslash
-	end tem)
+
+  (let* ((L (length definition))
+	 (start (if (> L 0) 0))
+	 end this-entry result tem)
     (while start
-      (setq convert-backslash nil)
-      ;; If we're reading from the mailrc file, then addresses are delimited
-      ;; by spaces, and addresses with embedded spaces must be surrounded by
-      ;; double-quotes.  Otherwise, addresses are separated by commas.
-      (if from-mailrc-file
-	  (if (eq ?\" (aref definition start))
-	      ;; The following test on `found' compensates for a bug
-	      ;; in match-end, which does not return nil when match
-	      ;; failed.
-	      (let ((found (string-match "[^\\]\\(\\([\\][\\]\\)*\\)\"[ \t,]*"
-					 definition start)))
-		(setq start (1+ start)
-		      end (and found (match-end 1))
-		      convert-backslash t))
-	    (setq end (string-match "[ \t,]+" definition start)))
-	(setq end (string-match "[ \t\n,]*,[ \t\n,]*" definition start)))
-      (let ((temp (substring definition start end))
-	    (pos 0))
-	(setq start (and end
-			 (/= (match-end 0) L)
-			 (match-end 0)))
-	(if convert-backslash
-	    (while (string-match "[\\]" temp pos)
-	      (setq temp (replace-match "" t t temp))
-	      (if start
-		  (setq start (1- start)))
-	      (setq pos (match-end 0))))
-	(setq result (cons temp result))))
+      (cond
+       (from-mailrc-file
+	;; If we're reading from the mailrc file, addresses are
+	;; delimited by spaces, and addresses with embedded spaces are
+	;; surrounded by non-escaped double-quotes.
+	(if (eq ?\" (aref definition start))
+	    (setq start (1+ start)
+		  end (and (string-match
+			    "[^\\]\\(\\([\\][\\]\\)*\\)\"[ \t,]*"
+			    definition start)
+			   (match-end 1)))
+	  (setq end (string-match "[ \t,]+" definition start)))
+	;; Extract the address and advance the loop past it.
+	(setq this-entry (substring definition start end)
+	      start (and end (/= (match-end 0) L) (match-end 0)))
+	;; If the full name contains a problem character, quote it.
+	(and (string-match "\\(.+?\\)[ \t]*\\(<.*>\\)" this-entry)
+	     (string-match "[^- !#$%&'*+/0-9=?A-Za-z^_`{|}~]"
+			   (match-string 1 this-entry))
+	     (setq this-entry (replace-regexp-in-string
+			       "\\(.+?\\)[ \t]*\\(<.*>\\)"
+			       "\"\\1\" \\2"
+			       this-entry))))
+       ;; When we are not reading from .mailrc, addresses are
+       ;; separated by commas.  Try to accept a rfc822-like syntax.
+       ;; (Todo: extend rfc822.el to do the work for us.)
+       ((equal (string-match
+		"[ \t,]*\\(\"\\(?:[^\"]\\|[^\\]\\(?:[\\][\\]\\)*\"\\)*\"[ \t]*\
+<[-.!#$%&'*+/0-9=?A-Za-z^_`{|}~@]+>\\)[ \t,]*"
+		definition start)
+	       start)
+	;; If an entry has a valid [ "foo bar" <foo@example.com> ]
+	;; form, use it literally .  This also allows commas in the
+	;; quoted string, e.g.  [ "foo bar, jr" <foo@example.com> ]
+	(setq this-entry (match-string 1 definition)
+	      start (and (/= (match-end 0) L) (match-end 0))))
+       (t
+	;; Otherwise, read the next address by looking for a comma.
+	(setq end (string-match "[ \t\n,]*,[ \t\n]*" definition start))
+	(setq this-entry (substring definition start end))
+	;; Advance the loop past this address.
+	(setq start (and end (/= (match-end 0) L) (match-end 0)))
+	;; If the full name contains a problem character, quote it.
+	(and (string-match "\\(.+?\\)[ \t]*\\(<.*>\\)" this-entry)
+	     (string-match "[^- !#$%&'*+/0-9=?A-Za-z^_`{|}~]"
+			   (match-string 1 this-entry))
+	     (setq this-entry (replace-regexp-in-string
+			       "\\(.+?\\)[ \t]*\\(<.*>\\)" "\"\\1\" \\2"
+			       this-entry)))))
+      (push this-entry result))
+
     (setq definition (mapconcat (function identity)
-				(nreverse result)
-				", "))
+				(nreverse result) ", "))
     (setq tem (assoc name mail-aliases))
     (if tem
 	(rplacd tem definition)
@@ -372,11 +392,9 @@ if it is quoted with double-quotes."
 	    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)
@@ -384,55 +402,72 @@ current header, calls `mail-complete-function' and passes prefix arg if any."
 	(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."
+  (declare (obsolete mail-completion-at-point-function "24.1"))
+  (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)
+(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)
-      (save-excursion
-	(set-buffer (generate-new-buffer " passwd"))
+      (with-current-buffer (generate-new-buffer " passwd")
 	(let ((files mail-passwd-files))
 	  (while files
 	    (insert-file-contents (car files) nil nil nil t)
@@ -463,7 +498,7 @@ PATTERN is the string we want to complete."
 	(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
@@ -479,59 +514,59 @@ PATTERN is the string we want to complete."
 				    (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)
+  (mail-completion-expand 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.
+(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."
-  (save-excursion
-    (message "Querying directory...")
-    (set-buffer (generate-new-buffer " *mail-directory*"))
-    (funcall mail-directory-function pattern)
-    (goto-char 1)
+  (message "Querying directory...")
+  (with-current-buffer (generate-new-buffer " *mail-directory*")
+    (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))))
@@ -551,5 +586,4 @@ See `mail-directory-stream'."
 
 (provide 'mailalias)
 
-;; arch-tag: 1d6a0f87-eb34-4d45-8816-60c1b952cf46
 ;;; mailalias.el ends here