suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: c2fa57b5d916546df9f1aacd4ae6ce75a2a18e08
This commit is contained in:
Matthew Flatt 2002-02-14 03:45:08 +00:00
parent c5a1b9e1be
commit b19dd4e482
1 changed files with 30 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/net/mime-unit.ss
View File

@ -33,7 +33,8 @@
"head-sig.ss" "head-sig.ss"
"mime-util.ss" "mime-util.ss"
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "etc.ss")) (lib "etc.ss")
(lib "string.ss"))
(provide net:mime@) (provide net:mime@)
(define net:mime@ (define net:mime@
@ -69,6 +70,7 @@
(define ietf-extensions '()) (define ietf-extensions '())
(define iana-extensions '(;; text (define iana-extensions '(;; text
("plain" . plain) ("plain" . plain)
("html" . html)
("richtext" . richtext) ("richtext" . richtext)
("tab-separated-values" . tab-separated-values) ("tab-separated-values" . tab-separated-values)
;; Multipart ;; Multipart
@ -279,38 +281,33 @@
;; Returns a list of input ports, each one containing the correspongind part. ;; Returns a list of input ports, each one containing the correspongind part.
(define multipart-body (define multipart-body
(lambda (input boundary) (lambda (input boundary)
(letrec ((eat-part (lambda () (let ([re:done (regexp (string-append "^--" (regexp-quote boundary) "--"))]
(let-values ([(pin pout) (make-pipe)]) [re:sep (regexp (string-append "^--" (regexp-quote boundary)))])
(let loop ((ln (read-line input))) (letrec ((eat-part (lambda ()
(cond ((eof-object? ln) (let-values ([(pin pout) (make-pipe)])
(close-output-port pout) (let loop ((ln (read-line input)))
(values pin;; part (cond ((eof-object? ln)
#f;; close-delimiter? (close-output-port pout)
#t;; eof reached? (values pin;; part
)) #f;; close-delimiter?
((regexp-match #t;; eof reached?
(regexp (string-append "^--" ))
boundary ((regexp-match re:done ln)
"--" (close-output-port pout)
)) ln) (values pin #t #f))
(close-output-port pout) ((regexp-match re:sep ln)
(values pin #t #f)) (close-output-port pout)
((regexp-match (values pin #f #f))
(regexp (string-append "^--" (else
boundary (fprintf pout "~a~n" ln)
)) ln) (loop (read-line input)))))))))
(close-output-port pout) (eat-part) ;; preamble
(values pin #f #f)) (let loop ()
(else (let-values ([(part close? eof?) (eat-part)])
(fprintf pout "~a~n" ln) (cond (close? (list part))
(loop (read-line input))))))))) (eof? null)
(eat-part) ;; preamble (else
(let loop () (cons part (loop))))))))))
(let-values ([(part close? eof?) (eat-part)])
(cond (close? (list part))
(eof? null)
(else
(cons part (loop)))))))))
;; MIME-message-headers := entity-headers ;; MIME-message-headers := entity-headers
;; fields ;; fields