From 71b7f21fdb568c17651640614f5cb7eb2d2426ba Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 3 Mar 2021 08:18:31 -0700 Subject: [PATCH] unzip: avoid blocking on break exception The `dynamic-wind` that causes problems dos not appear to be needed. Closes #3703 --- pkgs/racket-test/tests/file/unzip.rkt | 26 ++++++++++++- racket/collects/file/unzip.rkt | 55 +++++++++++++-------------- 2 files changed, 51 insertions(+), 30 deletions(-) diff --git a/pkgs/racket-test/tests/file/unzip.rkt b/pkgs/racket-test/tests/file/unzip.rkt index ddba603fc2..1b0bf749d2 100644 --- a/pkgs/racket-test/tests/file/unzip.rkt +++ b/pkgs/racket-test/tests/file/unzip.rkt @@ -39,7 +39,31 @@ (lambda (skip s evt) (lambda args 'void)) void)) (inflate infinite-voids out)) - =error> "non-character in an unsupported context")) + =error> "non-character in an unsupported context") + + ;; Check that a blocked input port can be interrupted: + (test (let () + (define zip + (bytes-append + #"PK\3\4\24\0\0\0\b\0\35FbR\237b\371AO\0\0\0x\0\0\0\5\0\34\0x.rkt" + #"UT\t\0\3j^>`l^>`ux\v\0\1\4\365\1\0\0\4\0\0\0\0S\316I\314KW(JL\316N-\321OJ," + #"N\345\342\322HIM\313\314KU\320HS\250\320\344RP\320\310LS\320(KM." + #"\311/\262W\250P0\4\211\201\200\2066LX7'5/\275$\3\242\34\n0\244`r\352\371" + #"\331@6\0PK\1\2\36\3\24\0\0\0\b\0\35FbR\237b\371AO\0\0\0x\0\0\0\5\0" + #"\30\0\0\0\0\0\1\0\0\0\244\201\0\0\0\0x.rktUT\5\0\3j^>`ux\v\0\1\4\365\1" + #"\0\0\4\0\0\0\0PK\5\6\0\0\0\0\1\0\1\0K\0\0\0\216\0\0\0\0\0")) + (define-values (i o) (make-pipe)) + (void (write-bytes (subbytes zip 0 100) o)) + (let ([t (thread + (lambda () + (with-handlers ([exn:break? void]) + (call-with-unzip i void))))]) + (sync (system-idle-evt)) + (break-thread t) + (sync t) + 'done)) + => 'done)) + (provide tests) (module+ main (tests)) diff --git a/racket/collects/file/unzip.rkt b/racket/collects/file/unzip.rkt index ef59ef681c..f271889b8f 100644 --- a/racket/collects/file/unzip.rkt +++ b/racket/collects/file/unzip.rkt @@ -201,38 +201,35 @@ [in0 (if (bitwise-bit-set? bits 3) in (make-limited-input-port in compressed #f))]) - (dynamic-wind - void - (lambda () - (define-values (in t) - (if (zero? compression) - (values in0 #f) - (make-filter-input-port inflate in0))) - - (if preserve-timestamps? - (read-entry filename dir? in (and (not dir?) - (msdos-date+time->seconds date time utc?))) - (read-entry filename dir? in)) + (define-values (in t) + (if (zero? compression) + (values in0 #f) + (make-filter-input-port inflate in0))) + + (if preserve-timestamps? + (read-entry filename dir? in (and (not dir?) + (msdos-date+time->seconds date time utc?))) + (read-entry filename dir? in)) - ;; Read until the end of the deflated stream when compressed size unknown - (when (bitwise-bit-set? bits 3) - (let loop () (unless (eof-object? (read-bytes 1024 in)) (loop)))) + ;; Read until the end of the deflated stream when compressed size unknown + (when (bitwise-bit-set? bits 3) + (let loop () (unless (eof-object? (read-bytes 1024 in)) (loop)))) - (when t (kill-thread t))) + (when t (kill-thread t)) - (lambda () - ;; appnote VI-C : if bit 3 is set, then the file data - ;; is immediately followed by a data descriptor - ;; appnote 4.3.9.3 : the value 0x08074b50 may appear - ;; as a data descriptor signature immediately - ;; following the file data - (if (bitwise-bit-set? bits 3) - ;; Read possibly signed data descriptor - (let ([maybe-signature (read-int 4)]) - (skip-bytes (if (= maybe-signature #x08074b50) 12 8) - in)) - (skip-bytes (- (+ mark compressed) (file-position in)) in))))) - (void)))) + ;; appnote VI-C : if bit 3 is set, then the file data + ;; is immediately followed by a data descriptor + ;; appnote 4.3.9.3 : the value 0x08074b50 may appear + ;; as a data descriptor signature immediately + ;; following the file data + (if (bitwise-bit-set? bits 3) + ;; Read possibly signed data descriptor + (let ([maybe-signature (read-int 4)]) + (skip-bytes (if (= maybe-signature #x08074b50) 12 8) + in)) + (skip-bytes (- (+ mark compressed) (file-position in)) in)) + + (void))))) ;; find-central-directory : input-port nat -> nat nat nat (define (find-central-directory in size)