;;; -*-Scheme-*-
;;;
-;;; $Id: rfc822.scm,v 1.1 2000/01/04 22:51:45 cph Exp $
+;;; $Id: rfc822.scm,v 1.2 2000/01/07 23:10:44 cph Exp $
;;;
;;; Copyright (c) 1999 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define (rfc822-first-address field)
- (let ((addresses (rfc822-strip-quoted-names field)))
+(define (rfc822-first-address string)
+ (let ((addresses (string->rfc822-addresses string)))
(and (pair? addresses)
(car addresses))))
(if (null? addresses)
""
(separated-append addresses ", ")))
-\f
-;;;; Address extractor
-(define (rfc822-strip-quoted-names string)
+(define (string->rfc822-addresses string)
(let ((address-list
- (rfc822-strip-quoted-names-1 (string->rfc822-tokens string))))
+ (rfc822-strip-quoted-names
+ (let loop ((tokens (string->rfc822-tokens string)))
+ (if (pair? 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 #t))
+ rest
+ (cons (car tokens) rest)))
+ '())))))
(if (and address-list (null? (cdr address-list)))
(car address-list)
(map string-trim (burst-string string #\, #f)))))
+\f
+(define (rfc822-strip-quoted-names tokens)
+ (define (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)))))))
-(define (rfc822-strip-quoted-names-1 tokens)
(define (parse-addr-spec tokens)
- (let ((local-part (parse-list tokens parse-word #\.)))
+ (let ((local-part (parse-list tokens #\. parse-word)))
(and local-part
- (not (null? (cdr local-part)))
+ (pair? (cdr local-part))
(eqv? #\@ (cadr local-part))
(let ((domain (parse-domain (cddr local-part))))
(and domain
"@"
(separated-append (car domain) "."))
(cdr domain)))))))
+
(define (parse-domain tokens)
- (parse-list tokens
- (lambda (tokens)
- (and (not (null? tokens))
- (string? (car tokens))
- (not (eqv? #\" (string-ref (car tokens) 0)))
- tokens))
- #\.))
- (define (parse-list tokens parse-element separator)
- (let ((first (parse-element tokens)))
- (and first
- (let loop ((tokens (cdr first)) (words (list (car first))))
- (let ((next
- (and (not (null? tokens))
- (eqv? separator (car tokens))
- (parse-element (cdr tokens)))))
- (if next
- (loop (cdr next) (cons (car next) words))
- (cons (reverse! words) tokens)))))))
+ (parse-list tokens #\.
+ (lambda (tokens)
+ (and (pair? tokens)
+ (string? (car tokens))
+ (not (eqv? #\" (string-ref (car tokens) 0)))
+ tokens))))
+
(define (parse-word tokens)
- (and (not (null? tokens))
+ (and (pair? tokens)
(string? (car tokens))
(not (eqv? #\[ (string-ref (car tokens) 0)))
tokens))
- (parse-list
- tokens
- (lambda (tokens)
- (or (parse-addr-spec tokens)
- (let ((word (parse-word tokens)))
- (and word
- (let ((tokens
- (let loop ((tokens (cdr word)))
- (let ((word (parse-word tokens)))
- (if word
- (loop (cdr word))
- tokens)))))
- (and (not (null? tokens))
- (eqv? #\< (car tokens))
- (let ((addr-spec
- (parse-addr-spec
- (let ((domains
- (parse-list
- (cdr tokens)
- (lambda (tokens)
- (and (not (null? tokens))
- (eqv? #\@ (car tokens))
- (parse-domain (cdr tokens))))
- #\,)))
- (if (and domains
- (not (null? (cdr domains)))
- (eqv? #\: (cadr domains)))
- (cddr domains)
- (cdr tokens))))))
- (and addr-spec
- (not (null? (cdr addr-spec)))
- (eqv? #\> (cadr addr-spec))
- (cons (car addr-spec) (cddr addr-spec))))))))))
- #\,))
+
+ (parse-list tokens #\,
+ (lambda (tokens)
+ (or (parse-addr-spec tokens)
+ (let ((word (parse-word tokens)))
+ (and word
+ (let ((tokens
+ (let loop ((tokens (cdr word)))
+ (let ((word (parse-word tokens)))
+ (if word
+ (loop (cdr word))
+ tokens)))))
+ (and (pair? tokens)
+ (eqv? #\< (car tokens))
+ (let ((addr-spec
+ (parse-addr-spec
+ (let ((domains
+ (parse-list (cdr tokens) #\,
+ (lambda (tokens)
+ (and (pair? tokens)
+ (eqv? #\@ (car tokens))
+ (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))))))))))))
\f
;;;; 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
+(define string->rfc822-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 ()
+ 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)
'())
- ((lwsp? char)
- (do ()
- ((not (lwsp? (input-port/peek-char port))))
- (input-port/discard-char port))
- (cons #\space (dispatch)))
+ ((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)))
(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))))
+ (if (next-lwsp? port)
+ (loop chars)
+ (loser chars)))
(else
(loop (cons char chars)))))))
-\f
((char=? #\( char)
;; comment
(let loop ((level 1) (chars (list 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))))
+ (if (next-lwsp? port)
+ (loop level chars)
+ (loser chars)))
(else
(loop level (cons char chars)))))))
((char=? #\[ char)
(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))))
+ (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)
- (let ((char (input-port/peek-char port)))
- (if (and (not (eof-object? char))
- (lwsp? char))
- (dispatch)
- '())))
+ (input-port/discard-char port)
+ (if (next-lwsp? port)
+ (skip-whitespace)
+ (loser '())))
(else
- (cons (if (special-char? char)
- char
- (cons 'ILLEGAL char))
- (dispatch))))))))))
\ No newline at end of file
+ (dispatch)))))
+
+ (dispatch)))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff