Don't quote lambda expressions with `quote'.
[bpt/emacs.git] / lisp / mh-e / mh-alias.el
1 ;;; mh-alias.el --- MH-E mail alias completion and expansion
2
3 ;; Copyright (C) 1994-1997, 2001-2011 Free Software Foundation, Inc.
4
5 ;; Author: Peter S. Galbraith <psg@debian.org>
6 ;; Maintainer: Bill Wohler <wohler@newt.com>
7 ;; Keywords: mail
8 ;; See: mh-e.el
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25 ;;; Commentary:
26
27 ;;; Change Log:
28
29 ;;; Code:
30
31 (require 'mh-e)
32
33 (mh-require-cl)
34
35 (require 'goto-addr)
36
37 (defvar mh-alias-alist 'not-read
38 "Alist of MH aliases.")
39 (defvar mh-alias-blind-alist nil
40 "Alist of MH aliases that are blind lists.")
41 (defvar mh-alias-passwd-alist nil
42 "Alist of aliases extracted from passwd file and their expansions.")
43 (defvar mh-alias-tstamp nil
44 "Time aliases were last loaded.")
45 (defvar mh-alias-read-address-map
46 (let ((map (copy-keymap minibuffer-local-completion-map)))
47 (define-key map "," 'mh-alias-minibuffer-confirm-address)
48 (define-key map " " 'self-insert-command)
49 map))
50
51 (defvar mh-alias-system-aliases
52 '("/etc/nmh/MailAliases" "/etc/mh/MailAliases"
53 "/usr/lib/mh/MailAliases" "/usr/share/mailutils/mh/MailAliases"
54 "/etc/passwd")
55 "*A list of system files which are a source of aliases.
56 If these files are modified, they are automatically reread. This list
57 need include only system aliases and the passwd file, since personal
58 alias files listed in your \"Aliasfile:\" MH profile component are
59 automatically included. You can update the alias list manually using
60 \\[mh-alias-reload].")
61
62 \f
63
64 ;;; Alias Loading
65
66 (defun mh-alias-tstamp (arg)
67 "Check whether alias files have been modified.
68 Return t if any file listed in the Aliasfile MH profile component has
69 been modified since the timestamp.
70 If ARG is non-nil, set timestamp with the current time."
71 (if arg
72 (let ((time (current-time)))
73 (setq mh-alias-tstamp (list (nth 0 time) (nth 1 time))))
74 (let ((stamp))
75 (car (memq t (mapcar
76 (function
77 (lambda (file)
78 (when (and file (file-exists-p file))
79 (setq stamp (nth 5 (file-attributes file)))
80 (or (> (car stamp) (car mh-alias-tstamp))
81 (and (= (car stamp) (car mh-alias-tstamp))
82 (> (cadr stamp) (cadr mh-alias-tstamp)))))))
83 (mh-alias-filenames t)))))))
84
85 (defun mh-alias-filenames (arg)
86 "Return list of filenames that contain aliases.
87 The filenames come from the Aliasfile profile component and are
88 expanded.
89 If ARG is non-nil, filenames listed in `mh-alias-system-aliases' are
90 appended."
91 (or mh-progs (mh-find-path))
92 (save-excursion
93 (let* ((filename (mh-profile-component "Aliasfile"))
94 (filelist (and filename (split-string filename "[ \t]+")))
95 (userlist
96 (mapcar
97 (function
98 (lambda (file)
99 (if (and mh-user-path file
100 (file-exists-p (expand-file-name file mh-user-path)))
101 (expand-file-name file mh-user-path))))
102 filelist)))
103 (if arg
104 (if (stringp mh-alias-system-aliases)
105 (append userlist (list mh-alias-system-aliases))
106 (append userlist mh-alias-system-aliases))
107 userlist))))
108
109 (defun mh-alias-gecos-name (gecos-name username comma-separator)
110 "Return a usable address string from a GECOS-NAME and USERNAME.
111 Use only part of the GECOS-NAME up to the first comma if
112 COMMA-SEPARATOR is non-nil."
113 (let ((res gecos-name))
114 ;; Keep only string until first comma if COMMA-SEPARATOR is t.
115 (if (and comma-separator
116 (string-match "^\\([^,]+\\)," res))
117 (setq res (match-string 1 res)))
118 ;; Replace "&" with capitalized username
119 (if (string-match "&" res)
120 (setq res (mh-replace-regexp-in-string "&" (capitalize username) res)))
121 ;; Remove " character
122 (if (string-match "\"" res)
123 (setq res (mh-replace-regexp-in-string "\"" "" res)))
124 ;; If empty string, use username instead
125 (if (string-equal "" res)
126 (setq res username))
127 ;; Surround by quotes if doesn't consist of simple characters
128 (if (not (string-match "^[ a-zA-Z0-9-]+$" res))
129 (setq res (concat "\"" res "\"")))
130 res))
131
132 (defun mh-alias-local-users ()
133 "Return an alist of local users from /etc/passwd.
134 Exclude all aliases already in `mh-alias-alist' from \"ali\""
135 (let (passwd-alist)
136 (with-current-buffer (get-buffer-create mh-temp-buffer)
137 (erase-buffer)
138 (cond
139 ((eq mh-alias-local-users t)
140 (if (file-readable-p "/etc/passwd")
141 (insert-file-contents "/etc/passwd")))
142 ((stringp mh-alias-local-users)
143 (insert mh-alias-local-users "\n")
144 (shell-command-on-region (point-min) (point-max) mh-alias-local-users t)
145 (goto-char (point-min))))
146 (while (< (point) (point-max))
147 (cond
148 ((looking-at "\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:]*\\):")
149 (when (> (string-to-number (match-string 2)) 200)
150 (let* ((username (match-string 1))
151 (gecos-name (match-string 3))
152 (realname (mh-alias-gecos-name
153 gecos-name username
154 mh-alias-passwd-gecos-comma-separator-flag))
155 (alias-name (if mh-alias-local-users-prefix
156 (concat mh-alias-local-users-prefix
157 (mh-alias-suggest-alias realname t))
158 username))
159 (alias-translation
160 (if (string-equal username realname)
161 (concat "<" username ">")
162 (concat realname " <" username ">"))))
163 (when (not (mh-assoc-string alias-name mh-alias-alist t))
164 (setq passwd-alist (cons (list alias-name alias-translation)
165 passwd-alist)))))))
166 (forward-line 1)))
167 passwd-alist))
168
169 (defun mh-alias-reload ()
170 "Reload MH aliases.
171
172 Since aliases are updated frequently, MH-E reloads aliases
173 automatically whenever an alias lookup occurs if an alias source has
174 changed. Sources include files listed in your \"Aliasfile:\" profile
175 component and your password file if option `mh-alias-local-users' is
176 turned on. However, you can reload your aliases manually by calling
177 this command directly.
178
179 This function runs `mh-alias-reloaded-hook' after the aliases have
180 been loaded."
181 (interactive)
182 (save-excursion
183 (message "Loading MH aliases...")
184 (mh-alias-tstamp t)
185 (mh-exec-cmd-quiet t "ali" "-nolist" "-nouser")
186 (setq mh-alias-alist nil)
187 (setq mh-alias-blind-alist nil)
188 (while (< (point) (point-max))
189 (cond
190 ((looking-at "^[ \t]")) ;Continuation line
191 ((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias
192 (when (not (mh-assoc-string (match-string 1) mh-alias-blind-alist t))
193 (setq mh-alias-blind-alist
194 (cons (list (match-string 1)) mh-alias-blind-alist))
195 (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist))))
196 ((looking-at "\\(.+\\): .*$") ; A new MH alias
197 (when (not (mh-assoc-string (match-string 1) mh-alias-alist t))
198 (setq mh-alias-alist
199 (cons (list (match-string 1)) mh-alias-alist)))))
200 (forward-line 1)))
201 (when mh-alias-local-users
202 (setq mh-alias-passwd-alist (mh-alias-local-users))
203 ;; Update aliases with local users, but leave existing aliases alone.
204 (let ((local-users mh-alias-passwd-alist)
205 user)
206 (while local-users
207 (setq user (car local-users))
208 (if (not (mh-assoc-string (car user) mh-alias-alist t))
209 (setq mh-alias-alist (append mh-alias-alist (list user))))
210 (setq local-users (cdr local-users)))))
211 (run-hooks 'mh-alias-reloaded-hook)
212 (message "Loading MH aliases...done"))
213
214 ;;;###mh-autoload
215 (defun mh-alias-reload-maybe ()
216 "Load new MH aliases."
217 (if (or (eq mh-alias-alist 'not-read) ; Doesn't exist?
218 (mh-alias-tstamp nil)) ; Out of date?
219 (mh-alias-reload)))
220
221 \f
222
223 ;;; Alias Expansion
224
225 (defun mh-alias-ali (alias &optional user)
226 "Return ali expansion for ALIAS.
227 ALIAS must be a string for a single alias.
228 If USER is t, then assume ALIAS is an address and call ali -user. ali
229 returns the string unchanged if not defined. The same is done here."
230 (condition-case err
231 (save-excursion
232 (let ((user-arg (if user "-user" "-nouser")))
233 (mh-exec-cmd-quiet t "ali" user-arg "-nolist" alias))
234 (goto-char (point-max))
235 (if (looking-at "^$") (delete-char -1))
236 (buffer-substring (point-min)(point-max)))
237 (error (progn
238 (message "%s" (error-message-string err))
239 alias))))
240
241 ;;;###mh-autoload
242 (defun mh-alias-expand (alias)
243 "Return expansion for ALIAS.
244 Blind aliases or users from /etc/passwd are not expanded."
245 (cond
246 ((mh-assoc-string alias mh-alias-blind-alist t)
247 alias) ; Don't expand a blind alias
248 ((mh-assoc-string alias mh-alias-passwd-alist t)
249 (cadr (mh-assoc-string alias mh-alias-passwd-alist t)))
250 (t
251 (mh-alias-ali alias))))
252
253 (mh-require 'crm nil t) ; completing-read-multiple
254 (mh-require 'multi-prompt nil t)
255
256 ;;;###mh-autoload
257 (defun mh-read-address (prompt)
258 "Read an address from the minibuffer with PROMPT."
259 (mh-alias-reload-maybe)
260 (if (not mh-alias-alist) ; If still no aliases, just prompt
261 (read-string prompt)
262 (let* ((minibuffer-local-completion-map mh-alias-read-address-map)
263 (completion-ignore-case mh-alias-completion-ignore-case-flag)
264 (the-answer
265 (cond ((fboundp 'completing-read-multiple)
266 (mh-funcall-if-exists
267 completing-read-multiple prompt mh-alias-alist nil nil))
268 ((featurep 'multi-prompt)
269 (mh-funcall-if-exists
270 multi-prompt "," nil prompt mh-alias-alist nil nil))
271 (t (split-string
272 (completing-read prompt mh-alias-alist nil nil) ",")))))
273 (if (not mh-alias-expand-aliases-flag)
274 (mapconcat 'identity the-answer ", ")
275 ;; Loop over all elements, checking if in passwd aliast or blind first
276 (mapconcat 'mh-alias-expand the-answer ",\n ")))))
277
278 ;;;###mh-autoload
279 (defun mh-alias-minibuffer-confirm-address ()
280 "Display the alias expansion if `mh-alias-flash-on-comma' is non-nil."
281 (interactive)
282 (when mh-alias-flash-on-comma
283 (save-excursion
284 (let* ((case-fold-search t)
285 (beg (mh-beginning-of-word))
286 (the-name (buffer-substring-no-properties beg (point))))
287 (if (mh-assoc-string the-name mh-alias-alist t)
288 (message "%s -> %s" the-name (mh-alias-expand the-name))
289 ;; Check if it was a single word likely to be an alias
290 (if (and (equal mh-alias-flash-on-comma 1)
291 (not (string-match " " the-name)))
292 (message "No alias for %s" the-name))))))
293 (self-insert-command 1))
294
295 ;;;###mh-autoload
296 (defun mh-alias-letter-expand-alias ()
297 "Expand mail alias before point."
298 (mh-alias-reload-maybe)
299 (let* ((begin (mh-beginning-of-word))
300 (end (save-excursion
301 (goto-char begin)
302 (mh-beginning-of-word -1))))
303 (when (>= end (point))
304 (list
305 begin (if (fboundp 'completion-at-point) end (point))
306 (if (not mh-alias-expand-aliases-flag)
307 mh-alias-alist
308 (lambda (string pred action)
309 (case action
310 ((nil)
311 (let ((res (try-completion string mh-alias-alist pred)))
312 (if (or (eq res t)
313 (and (stringp res)
314 (eq t (try-completion res mh-alias-alist pred))))
315 (or (mh-alias-expand (if (stringp res) res string))
316 res)
317 res)))
318 ((t) (all-completions string mh-alias-alist pred))
319 ((lambda) (if (fboundp 'test-completion)
320 (test-completion string mh-alias-alist pred))))))))))
321 \f
322
323 ;;; Alias File Updating
324
325 (defun mh-alias-suggest-alias (string &optional no-comma-swap)
326 "Suggest an alias for STRING.
327 Don't reverse the order of strings separated by a comma if
328 NO-COMMA-SWAP is non-nil."
329 (cond
330 ((string-match "^<\\(.*\\)>$" string)
331 ;; <somename@foo.bar> -> recurse, stripping brackets.
332 (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
333 ((string-match "^\\sw+$" string)
334 ;; One word -> downcase it.
335 (downcase string))
336 ((string-match "^\\(\\sw+\\)\\s-+\\(\\sw+\\)$" string)
337 ;; Two words -> first.last
338 (downcase
339 (format "%s.%s" (match-string 1 string) (match-string 2 string))))
340 ((string-match "^\\([-a-zA-Z0-9._]+\\)@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+$"
341 string)
342 ;; email only -> downcase username
343 (downcase (match-string 1 string)))
344 ((string-match "^\"\\(.*\\)\".*" string)
345 ;; "Some name" <somename@foo.bar> -> recurse -> "Some name"
346 (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
347 ((string-match "^\\(.*\\) +<.*>$" string)
348 ;; Some name <somename@foo.bar> -> recurse -> Some name
349 (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
350 ((string-match (concat goto-address-mail-regexp " +(\\(.*\\))$") string)
351 ;; somename@foo.bar (Some name) -> recurse -> Some name
352 (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
353 ((string-match "^\\(Dr\\|Prof\\)\\.? +\\(.*\\)" string)
354 ;; Strip out title
355 (mh-alias-suggest-alias (match-string 2 string) no-comma-swap))
356 ((string-match "^\\(.*\\), +\\(Jr\\.?\\|II+\\)$" string)
357 ;; Strip out tails with comma
358 (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
359 ((string-match "^\\(.*\\) +\\(Jr\\.?\\|II+\\)$" string)
360 ;; Strip out tails
361 (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
362 ((string-match "^\\(\\sw+\\) +[A-Z]\\.? +\\(.*\\)$" string)
363 ;; Strip out initials
364 (mh-alias-suggest-alias
365 (format "%s %s" (match-string 1 string) (match-string 2 string))
366 no-comma-swap))
367 ((and (not no-comma-swap)
368 (string-match "^\\([^,]+\\), +\\(.*\\)$" string))
369 ;; Reverse order of comma-separated fields to handle:
370 ;; From: "Galbraith, Peter" <psg@debian.org>
371 ;; but don't this for a name string extracted from the passwd file
372 ;; with mh-alias-passwd-gecos-comma-separator-flag set to nil.
373 (mh-alias-suggest-alias
374 (format "%s %s" (match-string 2 string) (match-string 1 string))
375 no-comma-swap))
376 (t
377 ;; Output string, with spaces replaced by dots.
378 (mh-alias-canonicalize-suggestion string))))
379
380 (defun mh-alias-canonicalize-suggestion (string)
381 "Process STRING to replace spaces by periods.
382 First all spaces and commas are replaced by periods. Then every run of
383 consecutive periods are replaced with a single period. Finally the
384 string is converted to lower case."
385 (with-temp-buffer
386 (insert string)
387 ;; Replace spaces with periods
388 (goto-char (point-min))
389 (while (re-search-forward " +" nil t)
390 (replace-match "." nil nil))
391 ;; Replace commas with periods
392 (goto-char (point-min))
393 (while (re-search-forward ",+" nil t)
394 (replace-match "." nil nil))
395 ;; Replace consecutive periods with a single period
396 (goto-char (point-min))
397 (while (re-search-forward "\\.\\.+" nil t)
398 (replace-match "." nil nil))
399 ;; Convert to lower case
400 (downcase-region (point-min) (point-max))
401 ;; Whew! all done...
402 (buffer-string)))
403
404 (defun mh-alias-which-file-has-alias (alias file-list)
405 "Return the name of writable file which defines ALIAS from list FILE-LIST."
406 (with-current-buffer (get-buffer-create mh-temp-buffer)
407 (let ((the-list file-list)
408 (found))
409 (while the-list
410 (erase-buffer)
411 (when (file-writable-p (car file-list))
412 (insert-file-contents (car file-list))
413 (if (re-search-forward (concat "^" (regexp-quote alias) ":") nil t)
414 (setq found (car file-list)
415 the-list nil)
416 (setq the-list (cdr the-list)))))
417 found)))
418
419 (defun mh-alias-insert-file (&optional alias)
420 "Return filename which should be used to add ALIAS.
421 The value of the option `mh-alias-insert-file' is used if non-nil\;
422 otherwise the value of the \"Aliasfile:\" profile component is used.
423 If the alias already exists, try to return the name of the file that
424 contains it."
425 (cond
426 ((and mh-alias-insert-file (listp mh-alias-insert-file))
427 (if (not (elt mh-alias-insert-file 1)) ; Only one entry, use it
428 (car mh-alias-insert-file)
429 (if (or (not alias)
430 (string-equal alias (mh-alias-ali alias))) ;alias doesn't exist
431 (completing-read "Alias file: "
432 (mapcar 'list mh-alias-insert-file) nil t)
433 (or (mh-alias-which-file-has-alias alias mh-alias-insert-file)
434 (completing-read "Alias file: "
435 (mapcar 'list mh-alias-insert-file) nil t)))))
436 ((and mh-alias-insert-file (stringp mh-alias-insert-file))
437 mh-alias-insert-file)
438 (t
439 ;; writable ones returned from (mh-alias-filenames):
440 (let ((autolist (delq nil (mapcar (lambda (file)
441 (if (and (file-writable-p file)
442 (not (string-equal
443 file "/etc/passwd")))
444 file))
445 (mh-alias-filenames t)))))
446 (cond
447 ((not autolist)
448 (error "No writable alias file;
449 set `mh-alias-insert-file' or the \"Aliasfile:\" profile component"))
450 ((not (elt autolist 1)) ; Only one entry, use it
451 (car autolist))
452 ((or (not alias)
453 (string-equal alias (mh-alias-ali alias))) ;alias doesn't exist
454 (completing-read "Alias file: " (mapcar 'list autolist) nil t))
455 (t
456 (or (mh-alias-which-file-has-alias alias autolist)
457 (completing-read "Alias file: "
458 (mapcar 'list autolist) nil t))))))))
459
460 ;;;###mh-autoload
461 (defun mh-alias-address-to-alias (address)
462 "Return the ADDRESS alias if defined, or nil."
463 (let* ((aliases (mh-alias-ali address t)))
464 (if (string-equal aliases address)
465 nil ; ali returned same string -> no.
466 ;; Double-check that we have an individual alias. This means that the
467 ;; alias doesn't expand into a list (of which this address is part).
468 (car (delq nil (mapcar
469 (function
470 (lambda (alias)
471 (let ((recurse (mh-alias-ali alias nil)))
472 (if (string-match ".*,.*" recurse)
473 nil
474 alias))))
475 (split-string aliases ", +")))))))
476
477 ;;;###mh-autoload
478 (defun mh-alias-for-from-p ()
479 "Return t if sender's address has a corresponding alias."
480 (mh-alias-reload-maybe)
481 (save-excursion
482 (if (not (mh-folder-line-matches-show-buffer-p))
483 nil ;No corresponding show buffer
484 (if (eq major-mode 'mh-folder-mode)
485 (set-buffer mh-show-buffer))
486 (let ((from-header (mh-extract-from-header-value)))
487 (and from-header
488 (mh-alias-address-to-alias from-header))))))
489
490 (defun mh-alias-add-alias-to-file (alias address &optional file)
491 "Add ALIAS for ADDRESS in alias FILE without alias check or prompts.
492 Prompt for alias file if not provided and there is more than one
493 candidate.
494
495 If the alias exists already, you will have the choice of
496 inserting the new alias before or after the old alias. In the
497 former case, this alias will be used when sending mail to this
498 alias. In the latter case, the alias serves as an additional
499 folder name hint when filing messages."
500 (if (not file)
501 (setq file (mh-alias-insert-file alias)))
502 (with-current-buffer (find-file-noselect file)
503 (goto-char (point-min))
504 (let ((alias-search (concat alias ":"))
505 (letter)
506 (case-fold-search t))
507 (cond
508 ;; Search for exact match (if we had the same alias before)
509 ((re-search-forward
510 (concat "^" (regexp-quote alias-search) " *\\(.*\\)") nil t)
511 (let ((answer (read-string
512 (format (concat "Alias %s exists; insert new address "
513 "[b]efore or [a]fter: ")
514 (match-string 1))))
515 (case-fold-search t))
516 (cond ((string-match "^b" answer))
517 ((string-match "^a" answer)
518 (forward-line 1))
519 (t
520 (error "Unrecognized response")))))
521 ;; No, so sort-in at the right place
522 ;; search for "^alias", then "^alia", etc.
523 ((eq mh-alias-insertion-location 'sorted)
524 (setq letter (substring alias-search -1)
525 alias-search (substring alias-search 0 -1))
526 (while (and (not (equal alias-search ""))
527 (not (re-search-forward
528 (concat "^" (regexp-quote alias-search)) nil t)))
529 (setq letter (substring alias-search -1)
530 alias-search (substring alias-search 0 -1)))
531 ;; Next, move forward to sort alphabetically for following letters
532 (beginning-of-line)
533 (while (re-search-forward
534 (concat "^" (regexp-quote alias-search) "[a-" letter "]")
535 nil t)
536 (forward-line 1)))
537 ((eq mh-alias-insertion-location 'bottom)
538 (goto-char (point-max)))
539 ((eq mh-alias-insertion-location 'top)
540 (goto-char (point-min)))))
541 (beginning-of-line)
542 (insert (format "%s: %s\n" alias address))
543 (save-buffer)))
544
545 (defun mh-alias-add-alias (alias address)
546 "Add ALIAS for ADDRESS in personal alias file.
547
548 This function prompts you for an alias and address. If the alias
549 exists already, you will have the choice of inserting the new
550 alias before or after the old alias. In the former case, this
551 alias will be used when sending mail to this alias. In the latter
552 case, the alias serves as an additional folder name hint when
553 filing messages."
554 (interactive "P\nP")
555 (mh-alias-reload-maybe)
556 (setq alias (completing-read "Alias: " mh-alias-alist nil nil alias))
557 (if (and address (string-match "^<\\(.*\\)>$" address))
558 (setq address (match-string 1 address)))
559 (setq address (read-string "Address: " address))
560 (if (string-match "^<\\(.*\\)>$" address)
561 (setq address (match-string 1 address)))
562 (let ((address-alias (mh-alias-address-to-alias address))
563 (alias-address (mh-alias-expand alias)))
564 (if (string-equal alias-address alias)
565 (setq alias-address nil))
566 (cond
567 ((and (equal alias address-alias)
568 (equal address alias-address))
569 (message "Already defined as %s" alias-address))
570 (address-alias
571 (if (y-or-n-p (format "Address has alias %s; set new one? "
572 address-alias))
573 (mh-alias-add-alias-to-file alias address)))
574 (t
575 (mh-alias-add-alias-to-file alias address)))))
576
577 ;;;###mh-autoload
578 (defun mh-alias-grab-from-field ()
579 "Add alias for the sender of the current message."
580 (interactive)
581 (mh-alias-reload-maybe)
582 (save-excursion
583 (cond
584 ((mh-folder-line-matches-show-buffer-p)
585 (set-buffer mh-show-buffer))
586 ((and (eq major-mode 'mh-folder-mode)
587 (mh-get-msg-num nil))
588 (set-buffer (get-buffer-create mh-temp-buffer))
589 (insert-file-contents (mh-msg-filename (mh-get-msg-num t))))
590 ((eq major-mode 'mh-folder-mode)
591 (error "Cursor not pointing to a message")))
592 (let* ((address (or (mh-extract-from-header-value)
593 (error "Message has no From: header")))
594 (alias (mh-alias-suggest-alias address)))
595 (mh-alias-add-alias alias address))))
596
597 (defun mh-alias-add-address-under-point ()
598 "Insert an alias for address under point."
599 (interactive)
600 (let ((address (goto-address-find-address-at-point)))
601 (if address
602 (mh-alias-add-alias nil address)
603 (message "No email address found under point"))))
604
605 (defun mh-alias-apropos (regexp)
606 "Show all aliases or addresses that match a regular expression REGEXP."
607 (interactive "sAlias regexp: ")
608 (if mh-alias-local-users
609 (mh-alias-reload-maybe))
610 (let ((matches "")
611 (group-matches "")
612 (passwd-matches))
613 (save-excursion
614 (message "Reading MH aliases...")
615 (mh-exec-cmd-quiet t "ali" "-nolist" "-nouser")
616 (message "Parsing MH aliases...")
617 (while (re-search-forward regexp nil t)
618 (beginning-of-line)
619 (cond
620 ((looking-at "^[ \t]") ;Continuation line
621 (setq group-matches
622 (concat group-matches
623 (buffer-substring
624 (save-excursion
625 (or (re-search-backward "^[^ \t]" nil t)
626 (point)))
627 (progn
628 (if (re-search-forward "^[^ \t]" nil t)
629 (forward-char -1))
630 (point))))))
631 (t
632 (setq matches
633 (concat matches
634 (buffer-substring (point)(progn (end-of-line)(point)))
635 "\n")))))
636 (message "Parsing MH aliases...done")
637 (when mh-alias-local-users
638 (message "Making passwd aliases...")
639 (setq passwd-matches
640 (mapconcat
641 (lambda (elem)
642 (if (or (string-match regexp (car elem))
643 (string-match regexp (cadr elem)))
644 (format "%s: %s\n" (car elem) (cadr elem))))
645 mh-alias-passwd-alist ""))
646 (message "Making passwd aliases...done")))
647 (if (and (string-equal "" matches)
648 (string-equal "" group-matches)
649 (string-equal "" passwd-matches))
650 (message "No matches")
651 (with-output-to-temp-buffer mh-aliases-buffer
652 (if (not (string-equal "" matches))
653 (princ matches))
654 (when (not (string-equal group-matches ""))
655 (princ "\nGroup Aliases:\n\n")
656 (princ group-matches))
657 (when (not (string-equal passwd-matches ""))
658 (princ "\nLocal User Aliases:\n\n")
659 (princ passwd-matches))))))
660
661 (defun mh-folder-line-matches-show-buffer-p ()
662 "Return t if the message under point in folder-mode is in the show buffer.
663 Return nil in any other circumstance (no message under point, no
664 show buffer, the message in the show buffer doesn't match."
665 (and (eq major-mode 'mh-folder-mode)
666 (mh-get-msg-num nil)
667 mh-show-buffer
668 (get-buffer mh-show-buffer)
669 (buffer-file-name (get-buffer mh-show-buffer))
670 (string-match ".*/\\([0-9]+\\)$"
671 (buffer-file-name (get-buffer mh-show-buffer)))
672 (string-equal
673 (match-string 1 (buffer-file-name (get-buffer mh-show-buffer)))
674 (int-to-string (mh-get-msg-num nil)))))
675
676 (provide 'mh-alias)
677
678 ;; Local Variables:
679 ;; indent-tabs-mode: nil
680 ;; sentence-end-double-space: nil
681 ;; End:
682
683 ;;; mh-alias.el ends here