home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / NeXT / GnuSource / emacs-15.0.3 / lisp / mailalias.el < prev    next >
Lisp/Scheme  |  1990-07-19  |  6KB  |  148 lines
  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 distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21.  
  22. ;; Called from sendmail-send-it, or similar functions,
  23. ;; only if some mail aliases are defined.
  24. (defun expand-mail-aliases (beg end)
  25.   "Expand all mail aliases in suitable header fields found between BEG and END.
  26. Suitable header fields are To, Cc and Bcc."
  27.   (if (eq mail-aliases t)
  28.       (progn (setq mail-aliases nil) (build-mail-aliases)))
  29.   (goto-char beg)
  30.   (setq end (set-marker (make-marker) end))
  31.   (let ((case-fold-search nil))
  32.     (while (let ((case-fold-search t))
  33.          (re-search-forward "^\\(to\\|cc\\|bcc\\):" end t))
  34.       (skip-chars-forward " \t")
  35.       (let ((beg1 (point))
  36.         end1 pos epos seplen
  37.         ;; DISABLED-ALIASES records aliases temporarily disabled
  38.         ;; while we scan text that resulted from expanding those aliases.
  39.         ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
  40.         ;; is where to reenable the alias (expressed as number of chars
  41.         ;; counting from END1).
  42.         (disabled-aliases nil))
  43.     (re-search-forward "^[^ \t]" end 'move)
  44.     (beginning-of-line)
  45.     (skip-chars-backward " \t\n")
  46.     (setq end1 (point-marker))
  47.     (goto-char beg1)
  48.     (while (< (point) end1)
  49.       (setq pos (point))
  50.       ;; Reenable any aliases which were disabled for ranges
  51.       ;; that we have passed out of.
  52.       (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
  53.         (setq disabled-aliases (cdr disabled-aliases)))
  54.       ;; EPOS gets position of end of next name;
  55.       ;; SEPLEN gets length of whitespace&separator that follows it.
  56.       (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t)
  57.           (setq epos (match-beginning 0)
  58.             seplen (- (point) epos))
  59.         (setq epos (marker-position end1) seplen 0))
  60.       (let (translation
  61.         (string (buffer-substring pos epos)))
  62.         (if (and (not (assoc string disabled-aliases))
  63.              (setq translation
  64.                (cdr (assoc string mail-aliases))))
  65.         (progn
  66.           ;; This name is an alias.  Disable it.
  67.           (setq disabled-aliases (cons (cons string (- end1 epos))
  68.                            disabled-aliases))
  69.           ;; Replace the alias with its expansion
  70.           ;; then rescan the expansion for more aliases.
  71.           (goto-char pos)
  72.           (insert translation)
  73.           (delete-region (point) (+ (point) (- epos pos)))
  74.           (goto-char pos))
  75.           ;; Name is not an alias.  Skip to start of next name.
  76.           (goto-char epos)
  77.           (forward-char seplen))))
  78.     (set-marker end1 nil)))
  79.     (set-marker end nil)))
  80.  
  81. ;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
  82. (defun build-mail-aliases (&optional file)
  83.   "Read mail aliases from ~/.mailrc and set mail-aliases."
  84.   (setq file (expand-file-name (or file "~/.mailrc")))
  85.   (let ((buffer nil)
  86.     (obuf (current-buffer)))
  87.     (unwind-protect
  88.     (progn
  89.       (setq buffer (generate-new-buffer "mailrc"))
  90.       (buffer-flush-undo buffer)
  91.       (set-buffer buffer)
  92.       (cond ((get-file-buffer file)
  93.          (insert (save-excursion
  94.                (set-buffer (get-file-buffer file))
  95.                (buffer-substring (point-min) (point-max)))))
  96.         ((not (file-exists-p file)))
  97.         (t (insert-file-contents file)))
  98.       ;; Don't lose if no final newline.
  99.       (goto-char (point-max))
  100.       (or (eq (preceding-char) ?\n) (newline))
  101.       (goto-char (point-min))
  102.       ;; handle "\\\n" continuation lines
  103.       (while (not (eobp))
  104.         (end-of-line)
  105.         (if (= (preceding-char) ?\\)
  106.         (progn (delete-char -1) (delete-char 1) (insert ?\ ))
  107.             (forward-char 1)))
  108.       (goto-char (point-min))
  109.       (while (or (re-search-forward "^a\\(lias\\|\\)[ \t]+" nil t)
  110.              (re-search-forward "^g\\(roup\\|\\)[ \t]+" nil t))
  111.         (re-search-forward "[^ \t]+")
  112.         (let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
  113.            (start (progn (skip-chars-forward " \t") (point))))
  114.           (end-of-line)
  115.           (define-mail-alias
  116.         name
  117.         (buffer-substring start (point)))))
  118.       mail-aliases)
  119.       (if buffer (kill-buffer buffer))
  120.       (set-buffer obuf))))
  121.  
  122. ;; Always autoloadable in case the user wants to define aliases
  123. ;; interactively or in .emacs.
  124. (defun define-mail-alias (name definition)
  125.   "Define NAME as a mail-alias that translates to DEFINITION."
  126.   (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
  127.   ;; Read the defaults first, if we have not done so.
  128.   (if (eq mail-aliases t)
  129.       (progn
  130.     (setq mail-aliases nil)
  131.     (if (file-exists-p "~/.mailrc")
  132.         (build-mail-aliases))))
  133.   (let (tem)
  134.     ;; ~/.mailrc contains addresses separated by spaces.
  135.     ;; mailers should expect addresses separated by commas.
  136.     (while (setq tem (string-match "[^ \t,][ \t,]+" definition tem))
  137.       (if (= (match-end 0) (length definition))
  138.       (setq definition (substring definition 0 (1+ tem)))
  139.     (setq definition (concat (substring definition
  140.                         0 (1+ tem))
  141.                  ", "
  142.                  (substring definition (match-end 0))))
  143.     (setq tem (+ 3 tem))))
  144.     (setq tem (assoc name mail-aliases))
  145.     (if tem
  146.     (rplacd tem definition)
  147.       (setq mail-aliases (cons (cons name definition) mail-aliases)))))
  148.