lisp/mailalias.el

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