2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-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
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
(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))
|
2021-04-26 07:57:47 -04:00
|
|
|
|
(define char-set:nonblank (char-set-invert char-set:blank))
|