lisp/mail/mailalias.el

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