From 9b11ac1572b7894289539f932bef60e84c64629a Mon Sep 17 00:00:00 2001 From: sperber Date: Thu, 9 Jan 2003 13:23:50 +0000 Subject: [PATCH] Remove %... procedure brain-damage from RFC822 code and use optional arguments instead. --- scheme/lib/rfc822.scm | 140 ++++++++++++++---------------------------- scheme/packages.scm | 2 - 2 files changed, 45 insertions(+), 97 deletions(-) diff --git a/scheme/lib/rfc822.scm b/scheme/lib/rfc822.scm index 7ed006d..cd702bd 100644 --- a/scheme/lib/rfc822.scm +++ b/scheme/lib/rfc822.scm @@ -46,41 +46,13 @@ ;;; broad-minded view of line-terminators: lines can be terminated by either ;;; cr/lf or just lf, and either terminating sequence is trimmed. ;;; -;;; If you need stricter parsing, you can call the lower-level procedure -;;; %READ-RFC-822-FIELD and %READ-RFC822-HEADERS procs. They take the -;;; read-line procedure as an extra parameter. This means that you can -;;; pass in a procedure that recognises only cr/lf's, or only cr's (for a -;;; Mac app, perhaps), and you can determine whether or not the terminators -;;; get trimmed. However, your read-line procedure must indicate the -;;; header-terminating empty line by returning *either* the empty string or -;;; the two-char string cr/lf (or the EOF object). - -;;; (read-rfc822-field [port]) -;;; (%read-rfc822-field read-line port) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Read one field from the port, and return two values [NAME BODY]: -;;; - NAME Symbol such as 'subject or 'to. The field name is converted -;;; to a symbol using the Scheme implementation's preferred -;;; case. If the implementation reads symbols in a case-sensitive -;;; fashion (e.g., scsh), lowercase is used. This means you can -;;; compare these symbols to quoted constants using EQ?. When -;;; printing these field names out, it looks best if you capitalise -;;; them with (CAPITALIZE-STRING (SYMBOL->STRING FIELD-NAME)). -;;; - BODY List of strings which are the field's body, e.g. -;;; ("shivers@lcs.mit.edu"). Each list element is one line -;;; from the field's body, so if the field spreads out -;;; over three lines, then the body is a list of three -;;; strings. The terminating cr/lf's are trimmed from each -;;; string. A leading space or a leading horizontal tab -;;; is also trimmed, but one and only one. -;;; When there are no more fields -- EOF or a blank line has terminated the -;;; header section -- then the procedure returns [#f #f]. -;;; -;;; The %READ-RFC822-FIELD variant allows you to specify your own -;;; read-line procedure. The one used by READ-RFC822-FIELD terminates -;;; lines with either cr/lf or just lf, and it trims the terminator -;;; from the line. Your read-line procedure should trim the terminator -;;; of a line so an empty line is returned just as an empty string. +;;; If you need stricter parsing, you can pass a read-line procedure +;;; as an extra parameter. This means that you can pass in a procedure +;;; that recognizes only cr/lf's, or only cr's (for a Mac app, +;;; perhaps), and you can determine whether or not the terminators get +;;; trimmed. However, your read-line procedure must indicate the +;;; header-terminating empty line by returning *either* the empty +;;; string or the two-char string cr/lf (or the EOF object). (define htab (ascii->char 9)) @@ -91,67 +63,48 @@ (lambda (s) (string->symbol (string-map char-downcase s))) (lambda (s) (string->symbol (string-map char-upcase s))))) -(define (read-rfc822-field . maybe-port) - (let-optionals maybe-port ((port (current-input-port))) - (%read-rfc822-field read-crlf-line port))) +(define (read-rfc822-field . args) + (let-optionals args ((port (current-input-port)) + (read-line read-crlf-line)) + (let ((line1 (read-line port))) + (if (or (eof-object? line1) + (zero? (string-length line1)) + (string=? line1 "\r\n")) ; In case read-line doesn't trim. -(define (%read-rfc822-field read-line port) - (let ((line1 (read-line port))) - (if (or (eof-object? line1) - (zero? (string-length line1)) - (string=? line1 "\r\n")) ; In case read-line doesn't trim. + (values #f #f) ; Blank line or EOF terminates header text. - (values #f #f) ; Blank line or EOF terminates header text. - - (cond - ((string-index line1 #\:) => ; Find the colon and - (lambda (colon) ; split out field name. - (let ((name (string->symbol-pref (substring line1 0 colon)))) - ;; Read in continuation lines. - (let lp ((lines (list (substring line1 - (+ colon 1) - (string-length line1))))) - (let ((c (peek-char port))) ; Could return EOF. -;;; RFC822: continuous lines has to start with a space or a htab - (if (or (eqv? c #\space) (eqv? c htab)) - (lp (cons (read-line port) lines)) - (values name (reverse lines)))))))) - (else (error "Illegal RFC 822 field syntax." line1)))))) ; No : + (cond + ((string-index line1 #\:) => ; Find the colon and + (lambda (colon) ; split out field name. + (let ((name (string->symbol-pref (substring line1 0 colon)))) + ;; Read in continuation lines. + (let lp ((lines (list (substring line1 + (+ colon 1) + (string-length line1))))) + (let ((c (peek-char port))) ; Could return EOF. + ;; RFC822: continuous lines has to start with a space or a htab + (if (or (eqv? c #\space) (eqv? c htab)) + (lp (cons (read-line port) lines)) + (values name (reverse lines)))))))) + (else (error "Illegal RFC 822 field syntax." line1))))))) ; No : -;;; (read-rfc822-headers [port]) -;;; (%read-rfc822-headers read-line port) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Read in and parse up a section of text that looks like the header portion -;;; of an RFC 822 message. Return an alist mapping a field name (a symbol -;;; such as 'date or 'subject) to a list of field bodies -- one for -;;; each occurence of the field in the header. So if there are five -;;; "Received-by:" fields in the header, the alist maps 'received-by -;;; to a five element list. Each body is in turn represented by a list -;;; of strings -- one for each line of the field. So a field spread across -;;; three lines would produce a three element body. -;;; -;;; The %READ-RFC822-HEADERS variant allows you to specify your own read-line -;;; procedure. See notes above for reasons why. - -(define (read-rfc822-headers . maybe-port) - (let-optionals maybe-port ((port (current-input-port))) - (%read-rfc822-headers read-crlf-line port))) - -(define (%read-rfc822-headers read-line port) - (let lp ((alist '())) - (receive (field val) (%read-rfc822-field read-line port) - (cond (field (cond ((assq field alist) => - (lambda (entry) - (set-cdr! entry (cons val (cdr entry))) - (lp alist))) - (else (lp (cons (list field val) alist))))) +(define (read-rfc822-headers . args) + (let-optionals args ((port (current-input-port)) + (read-line read-crlf-line)) + (let lp ((alist '())) + (receive (field val) (read-rfc822-field port read-line) + (cond (field (cond ((assq field alist) => + (lambda (entry) + (set-cdr! entry (cons val (cdr entry))) + (lp alist))) + (else (lp (cons (list field val) alist))))) - ;; We are done. Reverse the order of each entry and return. - (else (for-each (lambda (entry) - (set-cdr! entry (reverse (cdr entry)))) - alist) - alist))))) + ;; We are done. Reverse the order of each entry and return. + (else (for-each (lambda (entry) + (set-cdr! entry (reverse (cdr entry)))) + alist) + alist)))))) ;;; (rejoin-header-lines alist [separator]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -171,7 +124,6 @@ (cdr entry)))) alist))) - ;;; Given a set of RFC822 headers like this: ;;; From: shivers ;;; To: ziggy, @@ -211,9 +163,7 @@ '() headers)) - - -;;; Other desireable functionality +;;; Other desirable functionality ;;; - Unfolding long lines. ;;; - Lexing structured fields. ;;; - Unlexing structured fields into canonical form. diff --git a/scheme/packages.scm b/scheme/packages.scm index edb3145..d2a68c5 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -43,8 +43,6 @@ (define-interface rfc822-interface (export read-rfc822-headers read-rfc822-field - %read-rfc822-headers - %read-rfc822-field rejoin-header-lines get-header-all get-header-lines