#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
    2017, 2018, 2019, 2020 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme 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 of the License, or (at
your option) any later version.

MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Mail Aliases



(define-command define-mail-alias
  "Define NAME as a mail-alias that translates to DEFINITION."
  (lambda ()
    (let ((alias (prompt-for-string "Define mail alias" #f)))
      (list alias
	    (prompt-for-string
	     (string-append "Define " alias " as mail alias for")
	     #f))))
  (lambda (alias definition)
    (let ((definition (parse-mailrc-line definition 0)))
      (guarantee-mail-aliases)
      (define-mail-alias alias definition))))

(define (define-mail-alias alias definition)
  (let ((entry (find-mail-alias alias mail-aliases)))
    (if entry
	(set-cdr! entry definition)
	(begin
	  (set! mail-aliases (cons (cons alias definition) mail-aliases))
	  unspecific))))

(define (expand-mail-alias alias)
  (let loop ((alias alias) (disabled '()))
    (let ((entry
	   (and (not (find-mail-alias alias disabled))
		(find-mail-alias alias mail-aliases))))
      (cond (entry
	     (let ((disabled (cons entry disabled)))
	       (append-map! (lambda (definition)
			      (loop definition disabled))
			    (cdr entry))))
	    ((null? disabled) #f)
	    (else (list alias))))))

(define (find-mail-alias alias mail-aliases)
  (let loop ((mail-aliases mail-aliases))
    (and (pair? mail-aliases)
	 (if (string-ci=? alias (caar mail-aliases))
	     (car mail-aliases)
	     (loop (cdr mail-aliases))))))

(define (expand-mail-aliases start end)
  (guarantee-mail-aliases)
  (let loop ((start start))
    (let ((hs
	   (re-search-forward "^\\(resent-\\)?\\(to\\|cc\\|bcc\\):[ \t]*"
			      start end #t)))
      (if hs
	  (let ((he
		 (mark-left-inserting-copy
		  (skip-chars-backward
		   " \t\n"
		   (if (re-search-forward "^[^ \t]" hs end #f)
		       (re-match-start 0)
		       end)
		   hs))))
	    (let loop ((hs hs))
	      (cond ((re-search-forward "[ \t]*[\n,][ \t]*" hs he #f)
		     (let ((e (mark-left-inserting-copy (re-match-end 0))))
		       (expand-region hs (re-match-start 0))
		       (mark-temporary! e)
		       (loop e)))
		    ((mark< hs he)
		     (expand-region hs he))))
	    (mark-temporary! he)
	    (loop he))))))

(define (expand-region start end)
  (let ((strings (expand-mail-alias (extract-string start end))))
    (if strings
	(let ((point (mark-left-inserting-copy start)))
	  (delete-string point end)
	  (let loop ((strings strings))
	    (insert-string (car strings) point)
	    (if (pair? (cdr strings))
		(begin
		  (insert-string ", " point)
		  (loop (cdr strings)))))
	  (mark-temporary! point)))))

(define mail-aliases '())
(define mail-aliases-time #f)

(define (guarantee-mail-aliases)
  (let ((filename "~/.mailrc"))
    (let ((t (file-modification-time filename)))
      (if (and t (not (eqv? t mail-aliases-time)))
	  (begin
	    (set! mail-aliases-time t)
	    (for-each (lambda (entry)
			(define-mail-alias (car entry) (cdr entry)))
		      (parse-mailrc-file filename)))))))

(define (parse-mailrc-file filename)
  (call-with-input-file filename
    (lambda (port)
      (let loop ()
	(let ((line (read-mailrc-line port)))
	  (if line
	      (let ((r
		     (re-string-match "^\\(a\\|alias\\|g\\|group\\)[ \t]+"
				      line)))
		(if r
		    (let ((parsed-line
			   (parse-mailrc-line line (re-match-end-index 0 r))))
		      (if (null? (cdr parsed-line))
			  (loop)
			  (cons parsed-line (loop))))
		    (loop)))
	      '()))))))

(define (read-mailrc-line port)
  (let ((line (read-delimited-string char-set:newline port)))
    (and (not (eof-object? line))
	 (begin
	   (read-char port)
	   (let ((length (string-length line)))
	     (if (and (> length 0)
		      (char=? #\\ (string-ref line (- length 1))))
		 (let ((line* (read-mailrc-line port)))
		   (if line*
		       (string-append (substring line 0 (- length 1))
				      " "
				      line*)
		       (substring line 0 (- length 1))))
		 line))))))

(define (parse-mailrc-line line start)
  (let ((end (string-length line)))
    (let loop ((start start))
      (let ((nonblank
	     (substring-find-next-char-in-set line start end
					      char-set:nonblank)))
	(if nonblank
	    (let ((blank
		   (substring-find-next-char-in-set line nonblank end
						    char-set:blank)))
	      (if blank
		  (cons (substring line nonblank blank) (loop blank))
		  (list (substring line nonblank end))))
	    '())))))

(define char-set:newline (char-set #\newline))
(define char-set:blank (char-set #\space #\tab))
(define char-set:nonblank (char-set-invert char-set:blank))