[bpt/emacs.git] / lisp / mail / mailalias.el

;;; mailalias.el --- expand mailing address aliases defined in ~/.mailrc.

;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.

;; Maintainer: FSF
;; Keywords: mail

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; Basic functions for defining and expanding mail aliases.
;; These seal off the interface to the alias-definition parts of a
;; .mailrc file formatted for BSD's Mail or USL's mailx.

;;; Code:

(require 'sendmail)

;; Called from sendmail-send-it, or similar functions,
;; only if some mail aliases are defined.
(defun expand-mail-aliases (beg end &optional exclude)
  "Expand all mail aliases in suitable header fields found between BEG and END.
Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants.
Optional second arg EXCLUDE may be a regular expression defining text to be
removed from alias expansions."
  (sendmail-synch-aliases)
  (if (eq mail-aliases t)
      (progn (setq mail-aliases nil) (build-mail-aliases)))
  (goto-char beg)
  (setq end (set-marker (make-marker) end))
  (let ((case-fold-search nil))
    (while (let ((case-fold-search t))
	     (re-search-forward "^\\(to\\|cc\\|bcc\\|resent-to\\|resent-cc\\|resent-bcc\\):" end t))
      (skip-chars-forward " \t")
      (let ((beg1 (point))
	    end1 pos epos seplen
	    ;; DISABLED-ALIASES records aliases temporarily disabled
	    ;; while we scan text that resulted from expanding those aliases.
	    ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
	    ;; is where to reenable the alias (expressed as number of chars
	    ;; counting from END1).
	    (disabled-aliases nil))
	(re-search-forward "^[^ \t]" end 'move)
	(beginning-of-line)
	(skip-chars-backward " \t\n")
	(setq end1 (point-marker))
	(goto-char beg1)
	(while (< (point) end1)
	  (setq pos (point))
	  ;; Reenable any aliases which were disabled for ranges
	  ;; that we have passed out of.
	  (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
	    (setq disabled-aliases (cdr disabled-aliases)))
	  ;; EPOS gets position of end of next name;
	  ;; SEPLEN gets length of whitespace&separator that follows it.
	  (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t)
	      (setq epos (match-beginning 0)
		    seplen (- (point) epos))
	    (setq epos (marker-position end1) seplen 0))
	  (let (translation
		(string (buffer-substring pos epos)))
	    (if (and (not (assoc string disabled-aliases))
		     (setq translation
			   (cdr (assoc string mail-aliases))))
		(progn
		  ;; This name is an alias.  Disable it.
		  (setq disabled-aliases (cons (cons string (- end1 epos))
					       disabled-aliases))
		  ;; Replace the alias with its expansion
		  ;; then rescan the expansion for more aliases.
		  (goto-char pos)
		  (insert translation)
		  (if exclude
 		      (let ((regexp
			     (concat "\\b\\(" exclude "\\)\\b"))
			    (end (point-marker)))
			(goto-char pos)
			(while (re-search-forward regexp end t)
			  (replace-match ""))
			(goto-char end)))
		  (delete-region (point) (+ (point) (- epos pos)))
		  (goto-char pos))
	      ;; Name is not an alias.  Skip to start of next name.
	      (goto-char epos)
	      (forward-char seplen))))
	(set-marker end1 nil)))
    (set-marker end nil)))

;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
(defun build-mail-aliases (&optional file)
  "Read mail aliases from `~/.mailrc' and set `mail-aliases'."
  (setq file (expand-file-name (or file (or (getenv "MAILRC") "~/.mailrc"))))
  (let ((buffer nil)
	(obuf (current-buffer)))
    (unwind-protect
	(progn
	  (setq buffer (generate-new-buffer "mailrc"))
	  (buffer-disable-undo buffer)
	  (set-buffer buffer)
	  (while file
	    (cond ((get-file-buffer file)
		   (insert (save-excursion
			     (set-buffer (get-file-buffer file))
			     (buffer-substring (point-min) (point-max)))))
		  ((file-exists-p file) (insert-file-contents file))
		  ((file-exists-p (setq file (concat "~/" file)))
		   (insert-file-contents file))
		  (t (setq file nil)))
	    ;; Don't lose if no final newline.
	    (goto-char (point-max))
	    (or (eq (preceding-char) ?\n) (newline))
	    (goto-char (point-min))
	    ;; handle "\\\n" continuation lines
	    (while (not (eobp))
	      (end-of-line)
	      (if (= (preceding-char) ?\\)
		  (progn (delete-char -1) (delete-char 1) (insert ?\ ))
	        (forward-char 1)))
	    (goto-char (point-min))
	    ;; handle `source' directives -- Eddy/1994/May/25
	    (cond ((re-search-forward "^source[ \t]+" nil t)
		   (re-search-forward "\\S-+")
		   (setq file
			 (buffer-substring (match-beginning 0) (match-end 0)))
		   (beginning-of-line)
		   (insert "# ") ; to ensure we don't re-process this file
		   (beginning-of-line))
		  (t (setq file nil))))
	  (goto-char (point-min))
	  (while (or (re-search-forward "^a\\(lias\\|\\)[ \t]+" nil t)
		     (re-search-forward "^g\\(roup\\|\\)[ \t]+" nil t))
	    (re-search-forward "[^ \t]+")
	    (let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
		   (start (progn (skip-chars-forward " \t") (point))))
	      (end-of-line)
	      (define-mail-alias
		name
		(buffer-substring start (point))
		t)))
	  mail-aliases)
      (if buffer (kill-buffer buffer))
      (set-buffer obuf))))

;; Always autoloadable in case the user wants to define aliases
;; interactively or in .emacs.
;;;###autoload
(defun define-mail-alias (name definition &optional from-mailrc-file)
  "Define NAME as a mail alias that translates to DEFINITION.
This means that sending a message to NAME will actually send to DEFINITION.
DEFINITION can be one or more mail addresses separated by spaces.
An address can contain spaces if it is quoted with double-quotes."
  (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
  ;; Read the defaults first, if we have not done so.
  (sendmail-synch-aliases)
  (if (eq mail-aliases t)
      (progn
	(setq mail-aliases nil)
	(if (file-exists-p (or (getenv "MAILRC") "~/.mailrc"))
	    (build-mail-aliases))))
  ;; strip garbage from front and end
  (if (string-match "\\`[ \t\n,]+" definition)
      (setq definition (substring definition (match-end 0))))
  (if (string-match "[ \t\n,]+\\'" definition)
      (setq definition (substring definition 0 (match-beginning 0))))
  (let ((result '())
	;; If DEFINITION is null string, avoid looping even once.
	(start (and (not (equal definition "")) 0))
	(L (length definition))
	end tem)
    (while start
      ;; If we're reading from the mailrc file, then addresses are delimited
      ;; by spaces, and addresses with embedded spaces must be surrounded by
      ;; double-quotes.  Otherwise, addresses are separated by commas.
      (if from-mailrc-file
	  (if (eq ?\" (aref definition start))
	      (setq start (1+ start)
		    end (string-match "\"[ \t,]*" definition start))
	    (setq end (string-match "[ \t,]+" definition start)))
	(setq end (string-match "[ \t\n,]*,[ \t\n,]*" definition start)))
      (setq result (cons (substring definition start end) result))
      (setq start (and end
		       (/= (match-end 0) L)
		       (match-end 0))))
    (setq definition (mapconcat (function identity)
				(nreverse result)
				", "))
    (setq tem (assoc name mail-aliases))
    (if tem
	(rplacd tem definition)
      (setq mail-aliases (cons (cons name definition) mail-aliases)))))

(provide 'mailalias)

;;; mailalias.el ends here
Commit	Line	Data
6594deb0 ER	1	;;; mailalias.el --- expand mailing address aliases defined in ~/.mailrc.
6594deb0 ER	2
3a801d0c ER	3	;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
3a801d0c ER	4
e5167999	5	;; Maintainer: FSF
fd7fa35a	6	;; Keywords: mail
e5167999	7
80a677d9 JA	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
e5167999	12	;; the Free Software Foundation; either version 2, or (at your option)
80a677d9 JA	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
e41b2db1 ER	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
e5167999	30	;;; Code:
80a677d9	31
594906dd	32	(require 'sendmail)
c2db7f31	33
80a677d9 JA	34	;; Called from sendmail-send-it, or similar functions,
	35	;; only if some mail aliases are defined.
	36	(defun expand-mail-aliases (beg end &optional exclude)
	37	"Expand all mail aliases in suitable header fields found between BEG and END.
96846422 RS	38	Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants.
	39	Optional second arg EXCLUDE may be a regular expression defining text to be
	40	removed from alias expansions."
4351ed67	41	(sendmail-synch-aliases)
80a677d9 JA	42	(if (eq mail-aliases t)
	43	(progn (setq mail-aliases nil) (build-mail-aliases)))
	44	(goto-char beg)
	45	(setq end (set-marker (make-marker) end))
	46	(let ((case-fold-search nil))
	47	(while (let ((case-fold-search t))
6f8c78e1	48	(re-search-forward "^\\(to\\\|cc\\\|bcc\\\|resent-to\\\|resent-cc\\\|resent-bcc\\):" end t))
80a677d9 JA	49	(skip-chars-forward " \t")
	50	(let ((beg1 (point))
	51	end1 pos epos seplen
	52	;; DISABLED-ALIASES records aliases temporarily disabled
	53	;; while we scan text that resulted from expanding those aliases.
	54	;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
	55	;; is where to reenable the alias (expressed as number of chars
	56	;; counting from END1).
	57	(disabled-aliases nil))
	58	(re-search-forward "^[^ \t]" end 'move)
	59	(beginning-of-line)
	60	(skip-chars-backward " \t\n")
	61	(setq end1 (point-marker))
	62	(goto-char beg1)
	63	(while (< (point) end1)
	64	(setq pos (point))
	65	;; Reenable any aliases which were disabled for ranges
	66	;; that we have passed out of.
	67	(while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
	68	(setq disabled-aliases (cdr disabled-aliases)))
	69	;; EPOS gets position of end of next name;
	70	;; SEPLEN gets length of whitespace&separator that follows it.
	71	(if (re-search-forward "[ \t][\n,][ \t]" end1 t)
	72	(setq epos (match-beginning 0)
	73	seplen (- (point) epos))
	74	(setq epos (marker-position end1) seplen 0))
	75	(let (translation
	76	(string (buffer-substring pos epos)))
	77	(if (and (not (assoc string disabled-aliases))
	78	(setq translation
	79	(cdr (assoc string mail-aliases))))
	80	(progn
	81	;; This name is an alias. Disable it.
	82	(setq disabled-aliases (cons (cons string (- end1 epos))
	83	disabled-aliases))
	84	;; Replace the alias with its expansion
	85	;; then rescan the expansion for more aliases.
	86	(goto-char pos)
	87	(insert translation)
	88	(if exclude
	89	(let ((regexp
	90	(concat "\\b\\(" exclude "\\)\\b"))
	91	(end (point-marker)))
	92	(goto-char pos)
	93	(while (re-search-forward regexp end t)
	94	(replace-match ""))
	95	(goto-char end)))
	96	(delete-region (point) (+ (point) (- epos pos)))
	97	(goto-char pos))
	98	;; Name is not an alias. Skip to start of next name.
	99	(goto-char epos)
	100	(forward-char seplen))))
	101	(set-marker end1 nil)))
	102	(set-marker end nil)))
	103
	104	;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
	105	(defun build-mail-aliases (&optional file)
1ddea2ab	106	"Read mail aliases from `~/.mailrc' and set `mail-aliases'."
3c55fda0	107	(setq file (expand-file-name (or file (or (getenv "MAILRC") "~/.mailrc"))))
80a677d9 JA	108	(let ((buffer nil)
	109	(obuf (current-buffer)))
	110	(unwind-protect
	111	(progn
	112	(setq buffer (generate-new-buffer "mailrc"))
	113	(buffer-disable-undo buffer)
	114	(set-buffer buffer)
3c55fda0 RS	115	(while file
	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	((file-exists-p file) (insert-file-contents file))
	121	((file-exists-p (setq file (concat "~/" file)))
	122	(insert-file-contents file))
	123	(t (setq file nil)))
	124	;; Don't lose if no final newline.
	125	(goto-char (point-max))
	126	(or (eq (preceding-char) ?\n) (newline))
	127	(goto-char (point-min))
	128	;; handle "\\\n" continuation lines
	129	(while (not (eobp))
	130	(end-of-line)
	131	(if (= (preceding-char) ?\\)
	132	(progn (delete-char -1) (delete-char 1) (insert ?\ ))
80a677d9	133	(forward-char 1)))
3c55fda0 RS	134	(goto-char (point-min))
	135	;; handle `source' directives -- Eddy/1994/May/25
	136	(cond ((re-search-forward "^source[ \t]+" nil t)
	137	(re-search-forward "\\S-+")
	138	(setq file
	139	(buffer-substring (match-beginning 0) (match-end 0)))
	140	(beginning-of-line)
	141	(insert "# ") ; to ensure we don't re-process this file
	142	(beginning-of-line))
	143	(t (setq file nil))))
80a677d9 JA	144	(goto-char (point-min))
	145	(while (or (re-search-forward "^a\\(lias\\\|\\)[ \t]+" nil t)
	146	(re-search-forward "^g\\(roup\\\|\\)[ \t]+" nil t))
	147	(re-search-forward "[^ \t]+")
	148	(let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
	149	(start (progn (skip-chars-forward " \t") (point))))
	150	(end-of-line)
	151	(define-mail-alias
	152	name
37e379dd RS	153	(buffer-substring start (point))
37e379dd RS	154	t)))
80a677d9 JA	155	mail-aliases)
	156	(if buffer (kill-buffer buffer))
	157	(set-buffer obuf))))
	158
	159	;; Always autoloadable in case the user wants to define aliases
	160	;; interactively or in .emacs.
7229064d	161	;;;###autoload
37e379dd	162	(defun define-mail-alias (name definition &optional from-mailrc-file)
96846422	163	"Define NAME as a mail alias that translates to DEFINITION.
80a677d9	164	This means that sending a message to NAME will actually send to DEFINITION.
d066345b RS	165	DEFINITION can be one or more mail addresses separated by spaces.
d066345b RS	166	An address can contain spaces if it is quoted with double-quotes."
80a677d9 JA	167	(interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
80a677d9 JA	168	;; Read the defaults first, if we have not done so.
4351ed67	169	(sendmail-synch-aliases)
80a677d9 JA	170	(if (eq mail-aliases t)
	171	(progn
	172	(setq mail-aliases nil)
8837853e	173	(if (file-exists-p (or (getenv "MAILRC") "~/.mailrc"))
80a677d9	174	(build-mail-aliases))))
3af1a1f3 RS	175	;; strip garbage from front and end
3af1a1f3 RS	176	(if (string-match "\\`[ \t\n,]+" definition)
aa228418	177	(setq definition (substring definition (match-end 0))))
3af1a1f3	178	(if (string-match "[ \t\n,]+\\'" definition)
aa228418	179	(setq definition (substring definition 0 (match-beginning 0))))
37e379dd	180	(let ((result '())
cc4b6c02 RS	181	;; If DEFINITION is null string, avoid looping even once.
cc4b6c02 RS	182	(start (and (not (equal definition "")) 0))
37e379dd RS	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))
cc4b6c02 RS	193	(setq end (string-match "[ \t,]+" definition start)))
cc4b6c02 RS	194	(setq end (string-match "[ \t\n,],[ \t\n,]" definition start)))
37e379dd RS	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	", "))
80a677d9 JA	202	(setq tem (assoc name mail-aliases))
	203	(if tem
	204	(rplacd tem definition)
	205	(setq mail-aliases (cons (cons name definition) mail-aliases)))))
6594deb0	206
e8a57935 JB	207	(provide 'mailalias)
e8a57935 JB	208
6594deb0	209	;;; mailalias.el ends here