From: Chris Hanson Date: Thu, 8 Jun 2000 17:58:26 +0000 (+0000) Subject: Import RFC-822 support from IMAIL. X-Git-Tag: 20090517-FFI~3580 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=87e71458797e3024d1a4e80e870893b70e1e4715;p=mit-scheme.git Import RFC-822 support from IMAIL. --- diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 834cde203..c7fe6ec16 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.256 2000/05/08 17:34:51 cph Exp $ +$Id: edwin.pkg,v 1.257 2000/06/08 17:58:23 cph Exp $ Copyright (c) 1989-2000 Massachusetts Institute of Technology @@ -1451,7 +1451,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (files "sendmail") (parent (edwin)) (export (edwin) - char-set:rfc822-quoted edwin-command$mail edwin-command$mail-bcc edwin-command$mail-cc @@ -1500,7 +1499,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. mailer-version-string make-mail-buffer prepare-mail-buffer-for-sending - rfc822-quote send-mail-buffer)) (define-package (edwin mail-alias) @@ -1596,15 +1594,33 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. guarantee-rmail-variables-initialized make-in-reply-to-field prompt-for-rmail-output-filename - rfc822-addresses->string - rfc822-first-address rfc822-region->babyl rfc822-region-reply-headers - rfc822-strip-quoted-names rmail-output-to-rmail-file rmail-output-to-unix-mail-file rmail-spool-directory with-buffer-open)) + +(define-package (edwin rfc822) + (files "rfc822") + (parent (edwin)) + (export (edwin) + rfc822:addresses->string + rfc822:canonicalize-address-string + rfc822:first-address + rfc822:header-field-name? + rfc822:parse-addr-spec + rfc822:parse-domain + rfc822:parse-list + rfc822:parse-msg-id + rfc822:parse-word + rfc822:quote-string + rfc822:received-header-components + rfc822:string->addresses + rfc822:string->tokens + rfc822:strip-comments + rfc822:strip-quoted-names + rfc822:tokens->string)) (define-package (edwin stepper) (files "eystep") diff --git a/v7/src/edwin/rfc822.scm b/v7/src/edwin/rfc822.scm new file mode 100644 index 000000000..a8b0b86e1 --- /dev/null +++ b/v7/src/edwin/rfc822.scm @@ -0,0 +1,471 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: rfc822.scm,v 3.1 2000/06/08 17:58:24 cph Exp $ +;;; +;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology +;;; +;;; This program 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. +;;; +;;; This program 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 this program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; IMAIL mail reader: RFC-822 support + +(declare (usual-integrations)) + +(define rfc822:char-set:header-constituents + (char-set-difference (ascii-range->char-set 33 127) + (char-set #\:))) + +(define rfc822:char-set:not-header-constituents + (char-set-invert rfc822:char-set:header-constituents)) + +(define (rfc822:header-field-name? string start end) + (and (fix:< start end) + (not (substring-find-next-char-in-set + string start end rfc822:char-set:not-header-constituents)))) + +(define char-set:rfc822-quoted + (char-set-invert + (char-set-union char-set:alphanumeric + (apply char-set (string->list " !#$%&'*+-/=?^_`{|}~"))))) + +(define (rfc822:quote-string string) + (if (string-find-next-char-in-set string char-set:rfc822-quoted) + (let loop ((chars (string->list string)) (result (list #\"))) + (if (null? chars) + (list->string (reverse! (cons #\" result))) + (loop (cdr chars) + (cons (car chars) + (if (or (char=? #\\ (car chars)) + (char=? #\" (car chars))) + (cons #\\ result) + result))))) + string)) + +(define (rfc822:first-address string) + (let ((addresses (rfc822:string->addresses string))) + (and (pair? addresses) + (car addresses)))) + +(define (rfc822:addresses->string addresses) + (decorated-string-append "" ", " "" addresses)) + +(define (rfc822:string->addresses string) + (let ((address-list + (rfc822:strip-quoted-names + (rfc822:strip-whitespace! (rfc822:string->tokens string))))) + (if (and address-list (null? (cdr address-list))) + (car address-list) + (map string-trim (burst-string string #\, #f))))) + +(define (rfc822:canonicalize-address-string string) + (rfc822:addresses->string (rfc822:string->addresses string))) + +;;;; Parsers + +(define (rfc822:received-header-components string) + (let ((from #f) + (by #f) + (via #f) + (with '()) + (id #f) + (for #f) + (lose (lambda () (error "Malformed Received header:" string)))) + (let loop ((tokens + (rfc822:strip-whitespace! (rfc822:string->tokens string)))) + (cond ((not (pair? tokens)) + (lose)) + ((eqv? #\; (car tokens)) + (values from by via (reverse! with) id for + (let ((pv (rfc822:parse-date-time (cdr tokens)))) + (if (not (and (pair? pv) (null? (cdr pv)))) + (lose)) + (car pv)))) + ((not (string? (car tokens))) + (lose)) + ((string-ci=? "from" (car tokens)) + (let ((pv (rfc822:parse-domain (cdr tokens)))) + (if (not pv) + (lose)) + (set! from (car pv)) + (loop (cdr pv)))) + ((string-ci=? "by" (car tokens)) + (let ((pv (rfc822:parse-domain (cdr tokens)))) + (if (not pv) + (lose)) + (set! by (car pv)) + (loop (cdr pv)))) + ((string-ci=? "via" (car tokens)) + (if (not (pair? (cdr tokens))) + (lose)) + (set! via (cadr tokens)) + (loop (cddr tokens))) + ((string-ci=? "with" (car tokens)) + (if (not (pair? (cdr tokens))) + (lose)) + (set! with (cons (cadr tokens) with)) + (loop (cddr tokens))) + ((string-ci=? "id" (car tokens)) + (let ((pv + (or (rfc822:parse-msg-id (cdr tokens)) + ;; Kludge: it's a common error for mailers to + ;; put malformed message IDs here. + (and (pair? (cdr tokens)) + (string? (car tokens)) + (cdr tokens))))) + (if (not pv) + (lose)) + (set! id (car pv)) + (loop (cdr pv)))) + ((string-ci=? "for" (car tokens)) + (let ((pv + (or (rfc822:parse-addr-spec (cdr tokens)) + ;; Kludge: some losing mailers do this, even + ;; though it's illegal. + (rfc822:parse-msg-id (cdr tokens))))) + (if (not pv) + (lose)) + (set! for (car pv)) + (loop (cdr pv)))) + (else (lose)))))) + +(define (rfc822:parse-date-time tokens) + (let ((pv1 (rfc822:parse-date tokens))) + (and pv1 + (let ((pv2 (rfc822:parse-time (cdr pv1)))) + (and pv2 + (let ((pv3 (rfc822:parse-time-zone (cdr pv2)))) + (and pv3 + (cons (string->universal-time + (string-append (car pv1) + " " + (car pv2) + " " + (car pv3))) + (cdr pv3))))))))) + +(define (rfc822:parse-date tokens) + (let* ((pv1 (rfc822:parse-day-of-week tokens)) + (pv2 (rfc822:parse-number (cdr pv1)))) + (and pv2 + (let ((pv3 (rfc822:parse-month (cdr pv2)))) + (and pv3 + (let ((pv4 (rfc822:parse-number (cdr pv3)))) + (and pv4 + (cons (string-append (if (car pv1) + (string-append (car pv1) ", ") + "") + (car pv2) + " " + (car pv3) + " " + (car pv4)) + (cdr pv4))))))))) + +(define (rfc822:parse-day-of-week tokens) + (if (and (pair? tokens) + (string? (car tokens)) + (parse-date/time-component string->day-of-week (car tokens)) + (pair? (cdr tokens)) + (eqv? #\, (cadr tokens))) + (cons (car tokens) (cddr tokens)) + (cons #f tokens))) + +(define (rfc822:parse-month tokens) + (and (pair? tokens) + (string? (car tokens)) + (parse-date/time-component string->month (car tokens)) + tokens)) + +(define (rfc822:parse-time tokens) + (let ((pv1 (rfc822:parse-number tokens))) + (and pv1 + (pair? (cdr pv1)) + (eqv? #\: (cadr pv1)) + (let ((pv2 (rfc822:parse-number (cddr pv1)))) + (and pv2 + (pair? (cdr pv2)) + (eqv? #\: (cadr pv2)) + (let ((pv3 (rfc822:parse-number (cddr pv2)))) + (and pv3 + (cons (string-append (car pv1) + ":" + (car pv2) + ":" + (car pv3)) + (cdr pv3))))))))) + +(define (rfc822:parse-time-zone tokens) + (and (pair? tokens) + (string? (car tokens)) + (parse-date/time-component string->time-zone (car tokens)) + tokens)) + +(define (parse-date/time-component string->component string) + (let ((v (ignore-errors (lambda () (string->component string))))) + (and (not (condition? v)) + v))) + +(define (rfc822:parse-msg-id tokens) + (and (pair? tokens) + (eqv? #\< (car tokens)) + (let ((addr-spec (rfc822:parse-addr-spec (cdr tokens)))) + (and (pair? addr-spec) + (pair? (cdr addr-spec)) + (eqv? #\> (cadr addr-spec)) + (cons (car addr-spec) (cddr addr-spec)))))) + +(define (rfc822:parse-addr-spec tokens) + (let ((local-part (rfc822:parse-list tokens #\. rfc822:parse-word))) + (and (pair? local-part) + (pair? (cdr local-part)) + (eqv? #\@ (cadr local-part)) + (let ((domain (rfc822:parse-domain (cddr local-part)))) + (and (pair? domain) + (cons (string-append + (decorated-string-append "" "." "" (car local-part)) + "@" + (decorated-string-append "" "." "" (car domain))) + (cdr domain))))))) + +(define (rfc822:parse-domain tokens) + (rfc822:parse-list tokens #\. + (lambda (tokens) + (and (pair? tokens) + (string? (car tokens)) + (not (char=? #\" (string-ref (car tokens) 0))) + tokens)))) + +(define (rfc822:parse-word tokens) + (and (pair? tokens) + (string? (car tokens)) + (not (char=? #\[ (string-ref (car tokens) 0))) + tokens)) + +(define (rfc822:parse-number tokens) + (and (pair? tokens) + (string? (car tokens)) + (exact-nonnegative-integer? (string->number (car tokens))) + tokens)) + +(define (rfc822:parse-list tokens separator parse-element) + (let ((first (parse-element tokens))) + (and first + (let loop ((tokens (cdr first)) (words (list (car first)))) + (let ((next + (and (pair? tokens) + (eqv? separator (car tokens)) + (parse-element (cdr tokens))))) + (if next + (loop (cdr next) (cons (car next) words)) + (cons (reverse! words) tokens))))))) + +;;;; Token-stream filters + +(define (rfc822:tokens->string tokens) + (let ((port (make-accumulator-output-port))) + (do ((tokens tokens (cdr tokens))) + ((not (pair? tokens))) + (cond ((char? (car tokens)) + (write-char (car tokens) port)) + ((string? (car tokens)) + (write-string (car tokens) port)) + ((and (pair? (car tokens)) + (eq? 'ILLEGAL (caar tokens))) + (write-char (cdar tokens) port)) + (else + (error "Malformed RFC-822 token stream:" tokens)))) + (get-output-from-accumulator port))) + +(define rfc822:strip-whitespace! + (list-deletor! + (lambda (token) + (cond ((char? token) (eqv? #\space token)) + ((string? token) (char=? #\( (string-ref token 0))) + (else #f))))) + +(define (rfc822:strip-quoted-names tokens) + (rfc822:parse-list tokens #\, + (lambda (tokens) + (or (rfc822:parse-addr-spec tokens) + (let ((word (rfc822:parse-word tokens))) + (and word + (let ((tokens + (let loop ((tokens (cdr word))) + (let ((word (rfc822:parse-word tokens))) + (if word + (loop (cdr word)) + tokens))))) + (and (pair? tokens) + (eqv? #\< (car tokens)) + (let ((addr-spec + (rfc822:parse-addr-spec + (let ((domains + (rfc822:parse-list (cdr tokens) #\, + (lambda (tokens) + (and (pair? tokens) + (eqv? #\@ (car tokens)) + (rfc822:parse-domain + (cdr tokens))))))) + (if (and domains + (pair? (cdr domains)) + (eqv? #\: (cadr domains))) + (cddr domains) + (cdr tokens)))))) + (and addr-spec + (pair? (cdr addr-spec)) + (eqv? #\> (cadr addr-spec)) + (cons (car addr-spec) + (cddr addr-spec)))))))))))) + +(define (rfc822:strip-comments tokens) + (list-transform-negative tokens + (lambda (token) + (and (string? token) + (char=? #\( (string-ref token 0)))))) + +;;;; Tokenizer + +(define rfc822:string->tokens + (let* ((special-chars + (char-set #\( #\) #\[ #\] #\< #\> #\@ #\, #\; #\: #\\ #\" #\.)) + (atom-chars + (char-set-difference (ascii-range->char-set #x21 #x7F) + special-chars)) + (special-char? + (lambda (char) (char-set-member? special-chars char))) + (atom-char? (lambda (char) (char-set-member? atom-chars char))) + (loser + (lambda (chars) + (list (cons 'UNTERMINATED (apply string (reverse! chars)))))) + (next-lwsp? + (lambda (port) + (let ((char (input-port/peek-char port))) + (and (not (eof-object? char)) + (char-lwsp? char)))))) + (lambda (input-string) + (let ((port (string->input-port input-string))) + (define (dispatch) + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + '()) + ((char-lwsp? char) + (cons #\space (skip-whitespace))) + ((char=? #\newline char) + (if (next-lwsp? port) + (cons #\space (skip-whitespace)) + (loser '()))) + ((atom-char? char) + ;; atom + (let loop ((chars (list char))) + (let ((char (input-port/peek-char port))) + (if (and (not (eof-object? char)) + (atom-char? char)) + (begin + (input-port/discard-char port) + (loop (cons char chars))) + (cons (apply string (reverse! chars)) + (dispatch)))))) + ((char=? #\" char) + ;; quoted string + (let loop ((chars (list char))) + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + (loser chars)) + ((char=? #\" char) + (cons (apply string (reverse! (cons char chars))) + (dispatch))) + ((char=? #\\ char) + (let ((char (input-port/read-char port)) + (chars (cons char chars))) + (if (eof-object? char) + (loser chars) + (loop (cons char chars))))) + ((char=? #\newline char) + (if (next-lwsp? port) + (loop chars) + (loser chars))) + (else + (loop (cons char chars))))))) + ((char=? #\( char) + ;; comment + (let loop ((level 1) (chars (list char))) + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + (loser chars)) + ((char=? #\( char) + (loop (+ level 1) (cons char chars))) + ((char=? #\) char) + (let ((chars (cons char chars))) + (if (= level 1) + (cons (apply string (reverse! chars)) + (dispatch)) + (loop (- level 1) chars)))) + ((char=? #\\ char) + (let ((char (input-port/read-char port)) + (chars (cons char chars))) + (if (eof-object? char) + (loser chars) + (loop level (cons char chars))))) + ((char=? #\newline char) + (if (next-lwsp? port) + (loop level chars) + (loser chars))) + (else + (loop level (cons char chars))))))) + ((char=? #\[ char) + ;; domain literal + (let loop ((chars (list char))) + (let ((char (input-port/peek-char port))) + (cond ((or (eof-object? char) + (char=? #\[ char)) + (loser chars)) + ((char=? #\] char) + (input-port/discard-char port) + (cons (apply string (reverse! (cons char chars))) + (dispatch))) + ((char=? #\\ char) + (input-port/discard-char port) + (let ((char (input-port/read-char port)) + (chars (cons char chars))) + (if (eof-object? char) + (loser chars) + (loop (cons char chars))))) + ((char=? #\newline char) + (input-port/discard-char port) + (if (next-lwsp? char) + (loop chars) + (loser chars))) + (else + (input-port/discard-char port) + (loop (cons char chars))))))) + (else + (cons (if (special-char? char) char (cons 'ILLEGAL char)) + (dispatch)))))) + + (define (skip-whitespace) + (let ((char (input-port/peek-char port))) + (cond ((eof-object? char) + '()) + ((char-lwsp? char) + (input-port/discard-char port) + (skip-whitespace)) + ((char=? #\newline char) + (input-port/discard-char port) + (if (next-lwsp? port) + (skip-whitespace) + (loser '()))) + (else + (dispatch))))) + + (dispatch))))) \ No newline at end of file diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 050e5539a..186850795 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rmail.scm,v 1.70 2000/03/27 20:43:24 cph Exp $ +;;; $Id: rmail.scm,v 1.71 2000/06/08 17:58:26 cph Exp $ ;;; ;;; Copyright (c) 1991-2000 Massachusetts Institute of Technology ;;; @@ -1046,8 +1046,7 @@ original message into it." "[" (let ((from (fetch-first-field "from" start end))) (if from - (rfc822-addresses->string - (rfc822-strip-quoted-names from)) + (rfc822:canonicalize-address-string from) "")) ": " (or (fetch-first-field "subject" start end) "") @@ -1087,11 +1086,10 @@ original message into it." (let ((resent-reply-to (fetch-last-field "resent-reply-to" start end)) (from (fetch-first-field "from" start end))) `(("To" - ,(rfc822-addresses->string - (rfc822-strip-quoted-names - (or resent-reply-to - (fetch-all-fields "reply-to" start end) - from)))) + ,(rfc822:canonicalize-address-string + (or resent-reply-to + (fetch-all-fields "reply-to" start end) + from))) ("CC" ,(and cc? (let ((to @@ -1108,10 +1106,9 @@ original message into it." (or to cc)))) (and cc (let ((addresses - (dont-reply-to - (rfc822-strip-quoted-names cc)))) - (and (not (null? addresses)) - (rfc822-addresses->string addresses)))))))) + (dont-reply-to (rfc822:string->addresses cc)))) + (and (pair? addresses) + (rfc822:addresses->string addresses)))))))) ("In-reply-to" ,(if resent-reply-to (make-in-reply-to-field @@ -1202,18 +1199,6 @@ original message into it." (define (header-end start end) (or (search-forward "\n\n" start end false) end)) -(define (rfc822-strip-quoted-names string) - (let ((address-list (strip-quoted-names-1 (string->rfc822-tokens string)))) - (if (and address-list (null? (cdr address-list))) - (car address-list) - (let ((end (string-length string))) - (let loop ((start 0)) - (let ((index (substring-find-next-char string start end #\,))) - (if index - (cons (string-trim (substring string start index)) - (loop (+ index 1))) - (list (string-trim (substring string start end)))))))))) - (define (dont-reply-to addresses) (let ((pattern (re-compile-pattern @@ -1229,11 +1214,6 @@ original message into it." (else (cons (car addresses) (loop (cdr addresses)))))))) -(define (rfc822-addresses->string addresses) - (if (null? addresses) - "" - (separated-append addresses ", "))) - (define (separated-append tokens separator) (if (null? (cdr tokens)) (car tokens) @@ -1248,7 +1228,7 @@ original message into it." message-id) (message-id ;; Append from field to message-id if needed. - (let ((from (rfc822-first-address from))) + (let ((from (rfc822:first-address from))) (if (re-string-search-forward (let ((r (re-string-search-forward "@[^@]*\\'" from #f))) (if r @@ -1258,7 +1238,7 @@ original message into it." message-id (string-append message-id " (" from ")")))) (else - (let ((field (write-to-string (rfc822-first-address from)))) + (let ((field (write-to-string (rfc822:first-address from)))) (if date (string-append field "'s message of " date) field))))) @@ -1336,154 +1316,6 @@ original message into it." (cons (car addr-spec) (cddr addr-spec)))))))))) #\,)) -;;;; RFC 822 parser - -(define (string->rfc822-tokens string) - (rfc822-clean-tokens (rfc822-read-tokens (string->input-port string)))) - -(define (rfc822-clean-tokens tokens) - (let loop ((tokens tokens)) - (if (null? tokens) - '() - (let ((rest (loop (cdr tokens)))) - (if (cond ((char? (car tokens)) - (eqv? #\space (car tokens))) - ((string? (car tokens)) - (char=? #\( (string-ref (car tokens) 0))) - (else true)) - rest - (cons (car tokens) rest)))))) - -(define rfc822-read-tokens - (let* ((special-chars - (char-set #\( #\) #\[ #\] #\< #\> #\@ #\, #\; #\: #\\ #\" #\.)) - (atom-chars - (char-set-difference (ascii-range->char-set #x21 #x7F) - special-chars))) - (lambda (port) - (let ((special-char? - (lambda (char) (char-set-member? special-chars char))) - (atom-char? (lambda (char) (char-set-member? atom-chars char))) - (lwsp? - (lambda (char) (or (char=? #\space char) (char=? #\tab char)))) - (loser - (lambda (chars) - (list (cons 'UNTERMINATED (apply string (reverse! chars))))))) - (let dispatch () - (let ((char (input-port/read-char port))) - (cond ((eof-object? char) - '()) - ((lwsp? char) - (do () - ((not (lwsp? (input-port/peek-char port)))) - (input-port/discard-char port)) - (cons #\space (dispatch))) - ((atom-char? char) - ;; atom - (let loop ((chars (list char))) - (let ((char (input-port/peek-char port))) - (if (and (not (eof-object? char)) - (atom-char? char)) - (begin - (input-port/discard-char port) - (loop (cons char chars))) - (cons (apply string (reverse! chars)) - (dispatch)))))) - ((char=? #\" char) - ;; quoted string - (let loop ((chars (list char))) - (let ((char (input-port/read-char port))) - (cond ((eof-object? char) - (loser chars)) - ((char=? #\" char) - (cons (apply string (reverse! (cons char chars))) - (dispatch))) - ((char=? #\\ char) - (let ((char (input-port/read-char port)) - (chars (cons char chars))) - (if (eof-object? char) - (loser chars) - (loop (cons char chars))))) - ((char=? #\newline char) - (let ((char (input-port/peek-char port))) - (if (lwsp? char) - (begin - (input-port/discard-char port) - (loop (cons char chars))) - (loser chars)))) - (else - (loop (cons char chars))))))) - - ((char=? #\( char) - ;; comment - (let loop ((level 1) (chars (list char))) - (let ((char (input-port/read-char port))) - (cond ((eof-object? char) - (loser chars)) - ((char=? #\( char) - (loop (+ level 1) (cons char chars))) - ((char=? #\) char) - (let ((chars (cons char chars))) - (if (= level 1) - (cons (apply string (reverse! chars)) - (dispatch)) - (loop (- level 1) chars)))) - ((char=? #\\ char) - (let ((char (input-port/read-char port)) - (chars (cons char chars))) - (if (eof-object? char) - (loser chars) - (loop level (cons char chars))))) - ((char=? #\newline char) - (let ((char (input-port/peek-char port))) - (if (lwsp? char) - (begin - (input-port/discard-char port) - (loop level (cons char chars))) - (loser chars)))) - (else - (loop level (cons char chars))))))) - ((char=? #\[ char) - ;; domain literal - (let loop ((chars (list char))) - (let ((char (input-port/peek-char port))) - (cond ((or (eof-object? char) - (char=? #\[ char)) - (loser chars)) - ((char=? #\] char) - (input-port/discard-char port) - (cons (apply string (reverse! (cons char chars))) - (dispatch))) - ((char=? #\\ char) - (input-port/discard-char port) - (let ((char (input-port/read-char port)) - (chars (cons char chars))) - (if (eof-object? char) - (loser chars) - (loop (cons char chars))))) - ((char=? #\newline char) - (input-port/discard-char port) - (let ((char (input-port/peek-char port))) - (if (lwsp? char) - (begin - (input-port/discard-char port) - (loop (cons char chars))) - (loser chars)))) - (else - (input-port/discard-char port) - (loop (cons char chars))))))) - ((char=? #\newline char) - (let ((char (input-port/peek-char port))) - (if (and (not (eof-object? char)) - (lwsp? char)) - (dispatch) - '()))) - (else - (cons (if (special-char? char) - char - (cons 'ILLEGAL char)) - (dispatch)))))))))) - ;;;; Mail output (define-command rmail-output-to-rmail-file @@ -1572,7 +1404,7 @@ buffer visiting that file." (insert-string (string-append "From " - (or (rfc822-first-address + (or (rfc822:first-address (fetch-first-field "from" start (header-end start end))) "unknown") " " @@ -1595,12 +1427,6 @@ buffer visiting that file." (merge-pathnames (file-pathname default) (pathname-as-directory pathname)) pathname)))) - -(define (rfc822-first-address field) - (and field - (let ((addresses (rfc822-strip-quoted-names field))) - (and (not (null? addresses)) - (car addresses))))) ;;;; Editing @@ -1695,7 +1521,7 @@ Leaves original message, deleted, before the undigestified messages." (delete-string (skip-chars-backward " \t\n" end start) end) (insert-string "\n\037" end) (let ((digest-name - (rfc822-first-address + (rfc822:first-address (let ((hend (header-end start end))) (or (fetch-first-field "Reply-To" start hend) (fetch-first-field "To" start hend)