scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Remove %... procedure brain-damage from RFC822 code and use optional 

arguments instead.
This commit is contained in:
sperber 2003-01-09 13:23:50 +00:00
parent 788b75caf0
commit 9b11ac1572
2 changed files with 45 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
scheme/lib/rfc822.scm
View File

@ -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.

2
scheme/packages.scm
View File

@ -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