code.delx.au - gnu-emacs/blob - lisp/mail/mailalias.el

   1 ;;; mailalias.el --- expand mailing address aliases defined in ~/.mailrc.
   2
   3 ;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; Basic functions for defining and expanding mail aliases.
  27 ;; These seal off the interface to the alias-definition parts of a
  28 ;; .mailrc file formatted for BSD's Mail or USL's mailx.
  29
  30 ;;; Code:
  31
  32 (require 'sendmail)
  33
  34 ;; Called from sendmail-send-it, or similar functions,
  35 ;; only if some mail aliases are defined.
  36 (defun expand-mail-aliases (beg end &optional exclude)
  37   "Expand all mail aliases in suitable header fields found between BEG and END.
  38 Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants.
  39 Optional second arg EXCLUDE may be a regular expression defining text to be
  40 removed from alias expansions."
  41   (sendmail-synch-aliases)
  42   (if (eq mail-aliases t)
  43       (progn (setq mail-aliases nil) (build-mail-aliases)))
  44   (goto-char beg)
  45   (setq end (set-marker (make-marker) end))
  46   (let ((case-fold-search nil))
  47     (while (let ((case-fold-search t))
  48              (re-search-forward "^\\(to\\|cc\\|bcc\\|resent-to\\|resent-cc\\|resent-bcc\\):" end t))
  49       (skip-chars-forward " \t")
  50       (let ((beg1 (point))
  51             end1 pos epos seplen
  52             ;; DISABLED-ALIASES records aliases temporarily disabled
  53             ;; while we scan text that resulted from expanding those aliases.
  54             ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
  55             ;; is where to reenable the alias (expressed as number of chars
  56             ;; counting from END1).
  57             (disabled-aliases nil))
  58         (re-search-forward "^[^ \t]" end 'move)
  59         (beginning-of-line)
  60         (skip-chars-backward " \t\n")
  61         (setq end1 (point-marker))
  62         (goto-char beg1)
  63         (while (< (point) end1)
  64           (setq pos (point))
  65           ;; Reenable any aliases which were disabled for ranges
  66           ;; that we have passed out of.
  67           (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
  68             (setq disabled-aliases (cdr disabled-aliases)))
  69           ;; EPOS gets position of end of next name;
  70           ;; SEPLEN gets length of whitespace&separator that follows it.
  71           (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t)
  72               (setq epos (match-beginning 0)
  73                     seplen (- (point) epos))
  74             (setq epos (marker-position end1) seplen 0))
  75           (let (translation
  76                 (string (buffer-substring pos epos)))
  77             (if (and (not (assoc string disabled-aliases))
  78                      (setq translation
  79                            (cdr (assoc string mail-aliases))))
  80                 (progn
  81                   ;; This name is an alias.  Disable it.
  82                   (setq disabled-aliases (cons (cons string (- end1 epos))
  83                                                disabled-aliases))
  84                   ;; Replace the alias with its expansion
  85                   ;; then rescan the expansion for more aliases.
  86                   (goto-char pos)
  87                   (insert translation)
  88                   (if exclude
  89                       (let ((regexp
  90                              (concat "\\b\\(" exclude "\\)\\b"))
  91                             (end (point-marker)))
  92                         (goto-char pos)
  93                         (while (re-search-forward regexp end t)
  94                           (replace-match ""))
  95                         (goto-char end)))
  96                   (delete-region (point) (+ (point) (- epos pos)))
  97                   (goto-char pos))
  98               ;; Name is not an alias.  Skip to start of next name.
  99               (goto-char epos)
 100               (forward-char seplen))))
 101         (set-marker end1 nil)))
 102     (set-marker end nil)))
 103
 104 ;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
 105 (defun build-mail-aliases (&optional file)
 106   "Read mail aliases from `~/.mailrc' and set `mail-aliases'."
 107   (setq file (expand-file-name (or file (or (getenv "MAILRC") "~/.mailrc"))))
 108   (let ((buffer nil)
 109         (obuf (current-buffer)))
 110     (unwind-protect
 111         (progn
 112           (setq buffer (generate-new-buffer "mailrc"))
 113           (buffer-disable-undo buffer)
 114           (set-buffer buffer)
 115           (while file
 116             (cond ((get-file-buffer file)
 117                    (insert (save-excursion
 118                              (set-buffer (get-file-buffer file))
 119                              (buffer-substring (point-min) (point-max)))))
 120                   ((file-exists-p file) (insert-file-contents file))
 121                   ((file-exists-p (setq file (concat "~/" file)))
 122                    (insert-file-contents file))
 123                   (t (setq file nil)))
 124             ;; Don't lose if no final newline.
 125             (goto-char (point-max))
 126             (or (eq (preceding-char) ?\n) (newline))
 127             (goto-char (point-min))
 128             ;; handle "\\\n" continuation lines
 129             (while (not (eobp))
 130               (end-of-line)
 131               (if (= (preceding-char) ?\\)
 132                   (progn (delete-char -1) (delete-char 1) (insert ?\ ))
 133                 (forward-char 1)))
 134             (goto-char (point-min))
 135             ;; handle `source' directives -- Eddy/1994/May/25
 136             (cond ((re-search-forward "^source[ \t]+" nil t)
 137                    (re-search-forward "\\S-+")
 138                    (setq file
 139                          (buffer-substring (match-beginning 0) (match-end 0)))
 140                    (beginning-of-line)
 141                    (insert "# ") ; to ensure we don't re-process this file
 142                    (beginning-of-line))
 143                   (t (setq file nil))))
 144           (goto-char (point-min))
 145           (while (or (re-search-forward "^a\\(lias\\|\\)[ \t]+" nil t)
 146                      (re-search-forward "^g\\(roup\\|\\)[ \t]+" nil t))
 147             (re-search-forward "[^ \t]+")
 148             (let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
 149                    (start (progn (skip-chars-forward " \t") (point))))
 150               (end-of-line)
 151               (define-mail-alias
 152                 name
 153                 (buffer-substring start (point))
 154                 t)))
 155           mail-aliases)
 156       (if buffer (kill-buffer buffer))
 157       (set-buffer obuf))))
 158
 159 ;; Always autoloadable in case the user wants to define aliases
 160 ;; interactively or in .emacs.
 161 ;;;###autoload
 162 (defun define-mail-alias (name definition &optional from-mailrc-file)
 163   "Define NAME as a mail alias that translates to DEFINITION.
 164 This means that sending a message to NAME will actually send to DEFINITION.
 165 DEFINITION can be one or more mail addresses separated by spaces.
 166 An address can contain spaces if it is quoted with double-quotes."
 167   (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
 168   ;; Read the defaults first, if we have not done so.
 169   (sendmail-synch-aliases)
 170   (if (eq mail-aliases t)
 171       (progn
 172         (setq mail-aliases nil)
 173         (if (file-exists-p "~/.mailrc")
 174             (build-mail-aliases))))
 175   ;; strip garbage from front and end
 176   (if (string-match "\\`[ \t\n,]+" definition)
 177       (setq definition (substring definition (match-end 0))))
 178   (if (string-match "[ \t\n,]+\\'" definition)
 179       (setq definition (substring definition 0 (match-beginning 0))))
 180   (let ((result '())
 181         ;; If DEFINITION is null string, avoid looping even once.
 182         (start (and (not (equal definition "")) 0))
 183         (L (length definition))
 184         end tem)
 185     (while start
 186       ;; If we're reading from the mailrc file, then addresses are delimited
 187       ;; by spaces, and addresses with embedded spaces must be surrounded by
 188       ;; double-quotes.  Otherwise, addresses are separated by commas.
 189       (if from-mailrc-file
 190           (if (eq ?\" (aref definition start))
 191               (setq start (1+ start)
 192                     end (string-match "\"[ \t,]*" definition start))
 193             (setq end (string-match "[ \t,]+" definition start)))
 194         (setq end (string-match "[ \t\n,]*,[ \t\n,]*" definition start)))
 195       (setq result (cons (substring definition start end) result))
 196       (setq start (and end
 197                        (/= (match-end 0) L)
 198                        (match-end 0))))
 199     (setq definition (mapconcat (function identity)
 200                                 (nreverse result)
 201                                 ", "))
 202     (setq tem (assoc name mail-aliases))
 203     (if tem
 204         (rplacd tem definition)
 205       (setq mail-aliases (cons (cons name definition) mail-aliases)))))
 206
 207 (provide 'mailalias)
 208
 209 ;;; mailalias.el ends here