home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-19.28-src.tgz / tar.out / fsf / emacs / lisp / mailalias.el < prev    next >
Lisp/Scheme  |  1996-09-28  |  8KB  |  210 lines
  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 (or (getenv "MAILRC") "~/.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.       (while file
  117.         (cond ((get-file-buffer file)
  118.            (insert (save-excursion
  119.                  (set-buffer (get-file-buffer file))
  120.                  (buffer-substring (point-min) (point-max)))))
  121.           ((file-exists-p file) (insert-file-contents file))
  122.           ((file-exists-p (setq file (concat "~/" file)))
  123.            (insert-file-contents file))
  124.           (t (setq file nil)))
  125.         ;; Don't lose if no final newline.
  126.         (goto-char (point-max))
  127.         (or (eq (preceding-char) ?\n) (newline))
  128.         (goto-char (point-min))
  129.         ;; handle "\\\n" continuation lines
  130.         (while (not (eobp))
  131.           (end-of-line)
  132.           (if (= (preceding-char) ?\\)
  133.           (progn (delete-char -1) (delete-char 1) (insert ?\ ))
  134.             (forward-char 1)))
  135.         (goto-char (point-min))
  136.         ;; handle `source' directives -- Eddy/1994/May/25
  137.         (cond ((re-search-forward "^source[ \t]+" nil t)
  138.            (re-search-forward "\\S-+")
  139.            (setq file
  140.              (buffer-substring (match-beginning 0) (match-end 0)))
  141.            (beginning-of-line)
  142.            (insert "# ") ; to ensure we don't re-process this file
  143.            (beginning-of-line))
  144.           (t (setq file nil))))
  145.       (goto-char (point-min))
  146.       (while (or (re-search-forward "^a\\(lias\\|\\)[ \t]+" nil t)
  147.              (re-search-forward "^g\\(roup\\|\\)[ \t]+" nil t))
  148.         (re-search-forward "[^ \t]+")
  149.         (let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
  150.            (start (progn (skip-chars-forward " \t") (point))))
  151.           (end-of-line)
  152.           (define-mail-alias
  153.         name
  154.         (buffer-substring start (point))
  155.         t)))
  156.       mail-aliases)
  157.       (if buffer (kill-buffer buffer))
  158.       (set-buffer obuf))))
  159.  
  160. ;; Always autoloadable in case the user wants to define aliases
  161. ;; interactively or in .emacs.
  162. ;;;###autoload
  163. (defun define-mail-alias (name definition &optional from-mailrc-file)
  164.   "Define NAME as a mail alias that translates to DEFINITION.
  165. This means that sending a message to NAME will actually send to DEFINITION.
  166. DEFINITION can be one or more mail addresses separated by spaces.
  167. An address can contain spaces if it is quoted with double-quotes."
  168.   (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
  169.   ;; Read the defaults first, if we have not done so.
  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
  210.