From abda63b0acf82890bfa6093f52ee7a39b14c8db6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Feb 2002 14:36:25 +0000 Subject: [PATCH] . original commit: 2c7d941ff2cd56d17ad9d071155820bec9f782ab --- collects/net/mime-sig.ss | 2 +- collects/net/mime-unit.ss | 51 ++++++++++------------------- collects/net/qp-unit.ss | 67 ++++++++------------------------------- 3 files changed, 30 insertions(+), 90 deletions(-) diff --git a/collects/net/mime-sig.ss b/collects/net/mime-sig.ss index c4cb120..6983623 100644 --- a/collects/net/mime-sig.ss +++ b/collects/net/mime-sig.ss @@ -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 diff --git a/collects/net/mime-unit.ss b/collects/net/mime-unit.ss index dd741e0..5f07786 100644 --- a/collects/net/mime-unit.ss +++ b/collects/net/mime-unit.ss @@ -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) diff --git a/collects/net/qp-unit.ss b/collects/net/qp-unit.ss index 751f18c..f8616b5 100644 --- a/collects/net/qp-unit.ss +++ b/collects/net/qp-unit.ss @@ -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 \ No newline at end of file +;;; qp-unit.ss ends here