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 (defvar mail-aliases t
  33   "Alias of mail address aliases,
  34 or t meaning should be initialized from `~/.mailrc'.")
  35
  36 ;; Called from sendmail-send-it, or similar functions,
  37 ;; only if some mail aliases are defined.
  38 (defun expand-mail-aliases (beg end &optional exclude)
  39   "Expand all mail aliases in suitable header fields found between BEG and END.
  40 Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants.
  41 Optional second arg EXCLUDE may be a regular expression defining text to be
  42 removed from alias expansions."
  43   (if (eq mail-aliases t)
  44       (progn (setq mail-aliases nil) (build-mail-aliases)))
  45   (goto-char beg)
  46   (setq end (set-marker (make-marker) end))
  47   (let ((case-fold-search nil))
  48     (while (let ((case-fold-search t))
  49              (re-search-forward "^\\(to\\|cc\\|bcc\\|resent-to\\|resent-cc\\|resent-bcc\\):" end t))
  50       (skip-chars-forward " \t")
  51       (let ((beg1 (point))
  52             end1 pos epos seplen
  53             ;; DISABLED-ALIASES records aliases temporarily disabled
  54             ;; while we scan text that resulted from expanding those aliases.
  55             ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
  56             ;; is where to reenable the alias (expressed as number of chars
  57             ;; counting from END1).
  58             (disabled-aliases nil))
  59         (re-search-forward "^[^ \t]" end 'move)
  60         (beginning-of-line)
  61         (skip-chars-backward " \t\n")
  62         (setq end1 (point-marker))
  63         (goto-char beg1)
  64         (while (< (point) end1)
  65           (setq pos (point))
  66           ;; Reenable any aliases which were disabled for ranges
  67           ;; that we have passed out of.
  68           (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
  69             (setq disabled-aliases (cdr disabled-aliases)))
  70           ;; EPOS gets position of end of next name;
  71           ;; SEPLEN gets length of whitespace&separator that follows it.
  72           (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t)
  73               (setq epos (match-beginning 0)
  74                     seplen (- (point) epos))
  75             (setq epos (marker-position end1) seplen 0))
  76           (let (translation
  77                 (string (buffer-substring pos epos)))
  78             (if (and (not (assoc string disabled-aliases))
  79                      (setq translation
  80                            (cdr (assoc string mail-aliases))))
  81                 (progn
  82                   ;; This name is an alias.  Disable it.
  83                   (setq disabled-aliases (cons (cons string (- end1 epos))
  84                                                disabled-aliases))
  85                   ;; Replace the alias with its expansion
  86                   ;; then rescan the expansion for more aliases.
  87                   (goto-char pos)
  88                   (insert translation)
  89                   (if exclude
  90                       (let ((regexp
  91                              (concat "\\b\\(" exclude "\\)\\b"))
  92                             (end (point-marker)))
  93                         (goto-char pos)
  94                         (while (re-search-forward regexp end t)
  95                           (replace-match ""))
  96                         (goto-char end)))
  97                   (delete-region (point) (+ (point) (- epos pos)))
  98                   (goto-char pos))
  99               ;; Name is not an alias.  Skip to start of next name.
 100               (goto-char epos)
 101               (forward-char seplen))))
 102         (set-marker end1 nil)))
 103     (set-marker end nil)))
 104
 105 ;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
 106 (defun build-mail-aliases (&optional file)
 107   "Read mail aliases from `~/.mailrc' and set `mail-aliases'."
 108   (setq file (expand-file-name (or file "~/.mailrc")))
 109   (let ((buffer nil)
 110         (obuf (current-buffer)))
 111     (unwind-protect
 112         (progn
 113           (setq buffer (generate-new-buffer "mailrc"))
 114           (buffer-disable-undo buffer)
 115           (set-buffer buffer)
 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                 ((not (file-exists-p file)))
 121                 (t (insert-file-contents file)))
 122           ;; Don't lose if no final newline.
 123           (goto-char (point-max))
 124           (or (eq (preceding-char) ?\n) (newline))
 125           (goto-char (point-min))
 126           ;; handle "\\\n" continuation lines
 127           (while (not (eobp))
 128             (end-of-line)
 129             (if (= (preceding-char) ?\\)
 130                 (progn (delete-char -1) (delete-char 1) (insert ?\ ))
 131                 (forward-char 1)))
 132           (goto-char (point-min))
 133           (while (or (re-search-forward "^a\\(lias\\|\\)[ \t]+" nil t)
 134                      (re-search-forward "^g\\(roup\\|\\)[ \t]+" nil t))
 135             (re-search-forward "[^ \t]+")
 136             (let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
 137                    (start (progn (skip-chars-forward " \t") (point))))
 138               (end-of-line)
 139               (define-mail-alias
 140                 name
 141                 (buffer-substring start (point)))))
 142           mail-aliases)
 143       (if buffer (kill-buffer buffer))
 144       (set-buffer obuf))))
 145
 146 ;; Always autoloadable in case the user wants to define aliases
 147 ;; interactively or in .emacs.
 148 ;;;###autoload
 149 (defun define-mail-alias (name definition)
 150   "Define NAME as a mail alias that translates to DEFINITION.
 151 This means that sending a message to NAME will actually send to DEFINITION.
 152 DEFINITION can be one or more mail addresses separated by commas."
 153   (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
 154   ;; Read the defaults first, if we have not done so.
 155   (if (eq mail-aliases t)
 156       (progn
 157         (setq mail-aliases nil)
 158         (if (file-exists-p "~/.mailrc")
 159             (build-mail-aliases))))
 160   ;; strip garbage from front and end
 161   (if (string-match "\\`[ \t\n,]+" definition)
 162       (setq definition (substring definition (match-end 0))))
 163   (if (string-match "[ \t\n,]+\\'" definition)
 164       (setq definition (substring definition 0 (match-beginning 0))))
 165   (let ((first (aref definition 0))
 166         (last (aref definition (1- (length definition))))
 167         tem)
 168     (if (and (= first last) (memq first '(?\' ?\")))
 169         ;; Strip quotation marks.
 170         (setq definition (substring definition 1 (1- (length definition))))
 171       ;; ~/.mailrc contains addresses separated by spaces.
 172       ;; mailers should expect addresses separated by commas.
 173       (while (setq tem (string-match "[^ \t,][ \t,]+" definition tem))
 174         (if (= (match-end 0) (length definition))
 175             (setq definition (substring definition 0 (1+ tem)))
 176           (setq definition (concat (substring definition
 177                                               0 (1+ tem))
 178                                    ", "
 179                                    (substring definition (match-end 0))))
 180           (setq tem (+ 3 tem)))))
 181     (setq tem (assoc name mail-aliases))
 182     (if tem
 183         (rplacd tem definition)
 184       (setq mail-aliases (cons (cons name definition) mail-aliases)))))
 185
 186 (provide 'mailalias)
 187
 188 ;;; mailalias.el ends here