From 5f60b03703a8a29715b227f87248e9dbd1aebf51 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 1 Apr 2018 00:43:10 -0700 Subject: [PATCH] Fix bug: mime decoder wasn't properly flushing its output. --- src/edwin/edwin.pkg | 2 -- src/edwin/string.scm | 34 ---------------------------------- src/imail/imail-mime.scm | 39 ++++++++++++++++++--------------------- src/runtime/runtime.pkg | 9 +++------ 4 files changed, 21 insertions(+), 63 deletions(-) diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 353a4b306..ac19b4421 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -264,8 +264,6 @@ USA. substringbinary - textual-output-port->binary vector-8b-fill! vector-8b-find-next-char vector-8b-find-next-char-ci diff --git a/src/edwin/string.scm b/src/edwin/string.scm index 465c7639f..cfcfd5cd5 100644 --- a/src/edwin/string.scm +++ b/src/edwin/string.scm @@ -583,40 +583,6 @@ USA. ((not (fix:< i end))) (string-set! string j (integer->char (bytevector-u8-ref bv i)))) string)) - -(define (textual-input-port->binary textual-port) - - (define (has-bytes?) - (char-ready? textual-port)) - - (define (read-bytes! bv start end) - (let ((string (read-string (fix:- end start) textual-port))) - (if (or (not string) (eof-object? string)) - string - (let ((n (string-length string))) - (do ((i 0 (fix:+ i 1)) - (j start (fix:+ j 1))) - ((not (fix:< i n))) - (bytevector-u8-set! bv j (char->integer (string-ref string i)))) - n)))) - - (define (close) - (close-port textual-port)) - - (make-binary-port (make-non-channel-input-source has-bytes? read-bytes! close) - #f)) - -(define (textual-output-port->binary textual-port) - - (define (write-bytes bv start end) - (do ((i start (fix:+ i 1))) - ((not (fix:< i end))) - (write-char (integer->char (bytevector-u8-ref bv i)) textual-port))) - - (define (close) - (close-port textual-port)) - - (make-binary-port #f (make-non-channel-output-sink write-bytes close))) (define (decorated-string-append prefix infix suffix strings) (let ((infix (string-append suffix infix prefix))) diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm index 066865591..ab119c69f 100644 --- a/src/imail/imail-mime.scm +++ b/src/imail/imail-mime.scm @@ -34,7 +34,7 @@ USA. ;;; Any kind of object can be a MIME entity, provided that it ;;; implements MIME-ENTITY-BODY-STRUCTURE. A default method is ;;; provided if it instead implements MIME-ENTITY-HEADER-FIELDS and -;;; either MIME-ENTITY-BODY-SUBSTRING or WRITE-ENTITY-MIME-BODY, which +;;; either MIME-ENTITY-BODY-SUBSTRING or WRITE-MIME-ENTITY-BODY, which ;;; yield the literal text of the entity's body without decoding or ;;; interpretation. MIME-ENTITY-BODY-STRUCTURE should return a ;;; instance. @@ -765,7 +765,6 @@ USA. (decoder-initializer #f read-only #t) (decoder-finalizer #f read-only #t) (decoder-updater #f read-only #t) - (decoding-port-maker #f read-only #t) (caller-with-decoding-port #f read-only #t)) (define-guarantee mime-encoding "MIME codec") @@ -776,14 +775,14 @@ USA. (define (define-mime-encoding name encode:initialize encode:finalize encode:update decode:initialize decode:finalize decode:update - make-port call-with-port) + call-with-port) (hash-table/put! mime-encodings name (%make-mime-encoding name #f encode:initialize encode:finalize encode:update decode:initialize decode:finalize decode:update - make-port call-with-port)) + call-with-port)) name) (define (define-identity-mime-encoding name) @@ -796,7 +795,6 @@ USA. (lambda (port text?) text? port) output-port/flush-output output-port/write-string - (lambda (port text?) text? port) (lambda (port text? generator) text? (generator port))))) @@ -813,7 +811,7 @@ USA. (define (make-unknown-mime-encoding name) (let ((lose (lambda args args (error "Unknown MIME encoding name:" name)))) - (%make-mime-encoding name #f lose lose lose lose lose lose lose lose))) + (%make-mime-encoding name #f lose lose lose lose lose lose lose))) (define (call-with-mime-decoding-output-port encoding port text? generator) ((mime-encoding/caller-with-decoding-port @@ -849,17 +847,19 @@ USA. decode-quoted-printable:initialize decode-quoted-printable:finalize decode-quoted-printable:update - make-decode-quoted-printable-port call-with-decode-quoted-printable-output-port) (define (make-decode-base64-port* textual-port text?) - (make-decode-base64-port (textual-output-port->binary textual-port) text?)) + (make-decode-base64-port (textual->binary-port textual-port 'iso-8859-1) + text?)) (define (call-with-decode-base64-port* textual-port text? procedure) - (let ((port (make-decode-base64-port* textual-port text?))) - (let ((value (procedure port))) - (close-port port) - value))) + (let ((binary-port (textual->binary-port textual-port 'iso-8859-1))) + (let ((decoding-port (make-decode-base64-port binary-port text?))) + (let ((value (procedure decoding-port))) + (close-port decoding-port) + (flush-output-port binary-port) + value)))) (define-mime-encoding 'BASE64 encode-base64:initialize @@ -868,22 +868,19 @@ USA. decode-base64:initialize decode-base64:finalize decode-base64:update - make-decode-base64-port* call-with-decode-base64-port*) -(define (make-decode-binhex40-port* textual-port text?) - (make-decode-binhex40-port (textual-output-port->binary textual-port) text?)) - (define (call-with-decode-binhex40-port* textual-port text? procedure) - (let ((port (make-decode-binhex40-port* textual-port text?))) - (let ((value (procedure port))) - (close-port port) - value))) + (let ((binary-port (textual->binary-port textual-port 'iso-8859-1))) + (let ((decoding-port (make-decode-binhex40-port binary-port text?))) + (let ((value (procedure decoding-port))) + (close-port decoding-port) + (flush-output-port binary-port) + value)))) (define-mime-encoding 'BINHEX40 #f #f #f ;No BinHex encoder. decode-binhex40:initialize decode-binhex40:finalize decode-binhex40:update - make-decode-binhex40-port* call-with-decode-binhex40-port*) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f60ca108e..04428abc8 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2523,12 +2523,6 @@ USA. u8-ready? write-bytevector write-u8) - ;; Temporary hack: this allows these bindings to be seen by Edwin. - ;; Move these bindings back to (runtime) after 9.3 release. - (export () - make-binary-port - make-non-channel-input-source - make-non-channel-output-sink) (export (runtime) binary-port-sink binary-port-source @@ -2538,8 +2532,11 @@ USA. input-source-open? input-source-port input-source? + make-binary-port make-channel-input-source make-channel-output-sink + make-non-channel-input-source + make-non-channel-output-sink output-sink-channel output-sink-custom-length output-sink-custom-ref -- 2.25.1