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

.

Browse Source 
original commit: 2c7d941ff2cd56d17ad9d071155820bec9f782ab
This commit is contained in:
Matthew Flatt 2002-02-14 14:36:25 +00:00
parent b19dd4e482
commit abda63b0ac
3 changed files with 30 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/net/mime-sig.ss
View File

@ -22,7 +22,7 @@
(type subtype charset encoding
disposition params id
description other fields
parts body close))
parts body))
(struct disposition
(type filename creation
modification read

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

@ -34,7 +34,8 @@
"mime-util.ss"
(lib "unitsig.ss")
(lib "etc.ss")
(lib "string.ss"))
(lib "string.ss")
(lib "thread.ss"))
(provide net:mime@)
(define net:mime@
@ -120,7 +121,7 @@
;; Basic structures
(define-struct message (version entity fields))
(define-struct entity
(type subtype charset encoding disposition params id description other fields parts body close))
(type subtype charset encoding disposition params id description other fields parts body))
(define-struct disposition
(type filename creation modification read size params))
@ -188,7 +189,6 @@
null ;; fields
null ;; parts
null ;; body
void ;; thunk to kill body buffer
)))
(define make-default-message
@ -197,38 +197,19 @@
(define mime-decode
(lambda (entity input)
(case (entity-encoding entity)
((quoted-printable)
(let-values ([(body close-body)
(qp-decode-stream input)])
(set-entity-body! entity body)
(set-entity-close! entity close-body)))
((base64)
(let-values
([(body no-base64-in) (make-pipe 4096)])
(let ((body-thread
(thread (lambda ()
(base64-decode-stream input no-base64-in)
(close-output-port no-base64-in)))))
(set-entity-body! entity body)
(set-entity-close! entity (lambda ()
(kill-thread body-thread))))))
(else ;; 7bit, 8bit, binary
(let-values
([(body body-in) (make-pipe 4096)])
(let ((body-thread
(thread (lambda ()
(let loop ((c (read-char input)))
(cond ((eof-object? c)
(close-input-port input)
(close-output-port body-in))
(else
(display c body-in)
(loop (read-char input)))))))))
(set-entity-body! entity body)
(set-entity-close! entity (lambda ()
(kill-thread body-thread)))))))))
(set-entity-body!
entity
(case (entity-encoding entity)
((quoted-printable)
(lambda (output)
(qp-decode-stream input output)))
((base64)
(lambda (output)
(base64-decode-stream input output)))
(else ;; 7bit, 8bit, binary
(lambda (output)
(copy-port input output)))))))
(define mime-analyze
(opt-lambda (input (part #f))
(let* ((iport (if (string? input)

67
collects/net/qp-unit.ss
View File

@ -45,39 +45,19 @@
;; returns the quoted printable representation of STR.
(define qp-encode
(lambda (str)
(let-values ([(in close) (quoted-printable-encode str)])
(let ((out (open-output-string)))
(let loop ((c (read-char in)))
(cond ((eof-object? c) (close) (get-output-string out))
(else
(display c out)
(loop (read-char in)))))))))
(let ((out (open-output-string)))
(qp-encode-stream (open-input-string str) out)
(get-output-string out))))
;; qp-decode : string -> string
;; returns STR unqp.
(define qp-decode
(lambda (str)
(let-values ([(in close) (quoted-printable-decode str)])
(let ((out (open-output-string)))
(let loop ((c (read-char in)))
(cond ((eof-object? c) (close) (get-output-string out))
(else
(display c out)
(loop (read-char in)))))))))
(let ((out (open-output-string)))
(qp-decode-stream (open-input-string str) out)
(get-output-string out))))
(define quoted-printable-decode
(lambda (input)
(let-values
([(no-qp-out no-qp-in) (make-pipe 4096)])
(let ((no-qp-thread
(thread (lambda ()
(quoted-printable-do-decode input no-qp-in)
(close-output-port no-qp-in)))))
(values no-qp-out
(lambda ()
(kill-thread no-qp-thread)))))))
(define quoted-printable-do-decode
(define qp-decode-stream
(lambda (in out)
(let ((iport (cond ((input-port? in) in)
((string? in) (open-input-string in))
@ -85,9 +65,9 @@
(raise (make-qp-wrong-input))))))
(let loop ((ln (read-line iport 'return-linefeed)))
(cond ((eof-object? ln) (void)) ;; done reading
((> (string-length ln) 76)
(raise (make-qp-wrong-line-size (string-length ln))))
(else
(when (> (string-length ln) 76)
(warning "quoted-printable line is too long: ~a" (string-length ln)))
(quoted-printable-decode-line ln out)
(loop (read-line iport 'return-linefeed))))))))
@ -132,7 +112,7 @@
(define warning
(lambda (msg . args)
(fprintf (current-error-port)
(apply format (cons msg args)))
(apply format msg args))
(newline (current-error-port))))
(define hex-digit?
@ -144,23 +124,6 @@
(lambda (str)
(integer->char (string->number str 16))))
;; quoted-printable-encode :
;; (string | input-port) -> (values qp-input-port thunk)
;; the quoted-printable representation of input is given in the first
;; value returned value, a thunk to kill this port is given as second
;; returning value.
(define quoted-printable-encode
(lambda (input)
(let-values
([(qp-out qp-in) (make-pipe 4096)])
(let ((qp-thread
(thread (lambda ()
(quoted-printable-do-encode input qp-in)
(close-output-port qp-in)))))
(values qp-out
(lambda ()
(kill-thread qp-thread)))))))
(define qp-blank?
(lambda (char)
(or (char=? char #\space)
@ -212,7 +175,7 @@
;; return the remainder blanks
str))))))
(define quoted-printable-do-encode
(define qp-encode-stream
(lambda (in out)
(let ((iport (cond ((input-port? in) in)
((string? in) (open-input-string in))
@ -259,10 +222,6 @@
(lambda (octet)
(let ((dec (char->integer octet)))
(or (and (<= 33 dec) (<= dec 60))
(and (<= 62 dec) (<= dec 126))))))
(and (<= 62 dec) (<= dec 126)))))))))
(define qp-encode-stream quoted-printable-encode)
(define qp-decode-stream quoted-printable-decode))))
;;; qpr.ss ends here
;;; qp-unit.ss ends here