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