From c33707329cf45464f83b00abb3dc913850e22aae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 May 2014 07:27:46 -0600 Subject: [PATCH] racket/port: add a flushing tidy callback for `reencode-output-port` This change solves a long-standing problem that reencoded output was not flushed on exit, especially in the case that the current output port is reencoded. --- .../scribblings/reference/port-lib.scrbl | 5 +- .../racket-test/tests/racket/portlib.rktl | 82 ++++++++++--------- racket/collects/racket/port.rkt | 69 ++++++++++------ 3 files changed, 92 insertions(+), 64 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/port-lib.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/port-lib.scrbl index e98bb9b04f..76e3b2d1bd 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/port-lib.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/port-lib.scrbl @@ -421,7 +421,10 @@ the buffer when they are part of an incomplete encoding sequence. The resulting output port does not support atomic writes. An explicit flush or special-write to the output port can hang if the most -recently written bytes form an incomplete encoding sequence.} +recently written bytes form an incomplete encoding sequence. + +When the port is buffered, a @tech{tidy callback} is registered with +the current custodian (see @secref["custodians"]) to flush the buffer.} @defproc[(dup-input-port [in input-port?] diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/portlib.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/portlib.rktl index 4898dd09c2..ecff24b5bb 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/portlib.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/portlib.rktl @@ -746,47 +746,53 @@ (void)) ;; Check buffer modes: -(let ([i (open-input-string "abc")] - [o (open-output-string)]) - (test #f file-stream-buffer-mode i) - (test #f file-stream-buffer-mode o) - (let ([ei (reencode-input-port i "UTF-8")] - [eo (reencode-output-port o "UTF-8")]) - (test 'none file-stream-buffer-mode ei) - (test 'block file-stream-buffer-mode eo) +(let () + (define (check-buffering flush-output) + (let ([i (open-input-string "abc")] + [o (open-output-string)]) + (test #f file-stream-buffer-mode i) + (test #f file-stream-buffer-mode o) + (let ([ei (reencode-input-port i "UTF-8")] + [eo (reencode-output-port o "UTF-8")]) + (test 'none file-stream-buffer-mode ei) + (test 'block file-stream-buffer-mode eo) - (test (void) display 10 eo) - (test (void) display 12 eo) - (test (void) newline eo) - (test #"" get-output-bytes o) - (test (void) flush-output eo) - (test #"1012\n" get-output-bytes o) - - (test (void) file-stream-buffer-mode eo 'line) - (test 'line file-stream-buffer-mode eo) - (test (void) display 13 eo) - (test #"1012\n" get-output-bytes o) - (test (void) newline eo) - (test #"1012\n13\n" get-output-bytes o) - (test (void) flush-output eo) - (test #"1012\n13\n" get-output-bytes o) + (test (void) display 10 eo) + (test (void) display 12 eo) + (test (void) newline eo) + (test #"" get-output-bytes o) + (test (void) flush-output eo) + (test #"1012\n" get-output-bytes o) + + (test (void) file-stream-buffer-mode eo 'line) + (test 'line file-stream-buffer-mode eo) + (test (void) display 13 eo) + (test #"1012\n" get-output-bytes o) + (test (void) newline eo) + (test #"1012\n13\n" get-output-bytes o) + (test (void) flush-output eo) + (test #"1012\n13\n" get-output-bytes o) - (test (void) display 14 eo) - (test #"1012\n13\n" get-output-bytes o) - (test (void) file-stream-buffer-mode eo 'none) - (test #"1012\n13\n14" get-output-bytes o) - (test 'none file-stream-buffer-mode eo) - (test (void) display 15 eo) - (test #"1012\n13\n1415" get-output-bytes o) + (test (void) display 14 eo) + (test #"1012\n13\n" get-output-bytes o) + (test (void) file-stream-buffer-mode eo 'none) + (test #"1012\n13\n14" get-output-bytes o) + (test 'none file-stream-buffer-mode eo) + (test (void) display 15 eo) + (test #"1012\n13\n1415" get-output-bytes o) - (test #\a read-char ei) - (test #\b peek-char i) - (test (void) file-stream-buffer-mode ei 'block) - (test 'block file-stream-buffer-mode ei) - (test #\b read-char ei) - (test eof peek-char i) - (test #\c read-char ei) - (test eof read-char ei))) + (test #\a read-char ei) + (test #\b peek-char i) + (test (void) file-stream-buffer-mode ei 'block) + (test 'block file-stream-buffer-mode ei) + (test #\b read-char ei) + (test eof peek-char i) + (test #\c read-char ei) + (test eof read-char ei)))) + ;; (check-buffering flush-output) + (let ([c (make-custodian)]) + (parameterize ([current-custodian c]) + (check-buffering (lambda (o) (custodian-tidy-all c)))))) (err/rt-test (port->bytes (reencode-input-port (open-input-bytes #"\xFF\xFF") "utf-8")) diff --git a/racket/collects/racket/port.rkt b/racket/collects/racket/port.rkt index 0ca264bc61..a7796a4bf2 100644 --- a/racket/collects/racket/port.rkt +++ b/racket/collects/racket/port.rkt @@ -1636,7 +1636,10 @@ [out-end 0] [buffer-mode (or (file-stream-buffer-mode port) 'block)] [debuffer-buf #f] - [newline-buffer #f]) + [newline-buffer #f] + [cust (current-custodian)] + [tidy-callback #f] + [self #f]) (define-values (buffered-r buffered-w) (make-pipe 4096)) ;; The main writing entry point: @@ -1649,7 +1652,9 @@ (flush-buffer-pipe #f enable-break?) (flush-some #f enable-break?) (if (buffer-flushed?) - 0 + (begin + (buffering! #f) + 0) (write-it s start end no-buffer&block? enable-break?))] [no-buffer&block? (case (flush-all #t enable-break?) @@ -1671,6 +1676,7 @@ [(and (eq? buffer-mode 'block) (zero? (pipe-content-length buffered-r))) ;; The port system can buffer to a pipe faster, so give it a pipe. + (buffering! #t) buffered-w] [else ;; Flush/buffer from pipe, first: @@ -1687,6 +1693,7 @@ (write-it s start end #f enable-break?) ;; Buffer and report success: (begin + (buffering! #t) (bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2)) (set! out-end (+ cnt2 out-end)) (case buffer-mode @@ -1837,7 +1844,9 @@ [orig-out-end out-end]) (flush-some non-block? enable-break?) (if (buffer-flushed?) - 'done + (begin + (buffering! #f) + 'done) ;; Couldn't flush everything. One possibility is that we need ;; more bytes to convert before a flush. (if (and orig-none-ready? @@ -1857,6 +1866,14 @@ (= out-start out-end) (zero? (pipe-content-length buffered-r)))) + (define (buffering! on?) + (cond + [(and on? (not tidy-callback)) + (set! tidy-callback (custodian-add-tidy! cust (lambda (e) (flush-output self))))] + [(and (not on?) tidy-callback) + (custodian-remove-tidy! tidy-callback) + (set! tidy-callback #f)])) + ;; Try to flush immediately a certain number of bytes. ;; we've already converted them, so we have to keep ;; the bytes in any case. @@ -1913,28 +1930,30 @@ "could not create converter from ~e to UTF-8" encoding)) - (make-output-port - name - port - write-it - (lambda () - ;; Flush output - (write-it #"" 0 0 #f #f) - (when close? - (close-output-port port)) - (bytes-close-converter c)) - write-special-it - #f #f - #f void - 1 - (case-lambda - [() buffer-mode] - [(mode) (let ([old buffer-mode]) - (set! buffer-mode mode) - (when (or (and (eq? old 'block) (memq mode '(none line))) - (and (eq? old 'line) (memq mode '(none)))) - ;; Flush output - (write-it #"" 0 0 #f #f)))]))))) + (set! self + (make-output-port + name + port + write-it + (lambda () + ;; Flush output + (flush-output self) + (when close? + (close-output-port port)) + (bytes-close-converter c)) + write-special-it + #f #f + #f void + 1 + (case-lambda + [() buffer-mode] + [(mode) (let ([old buffer-mode]) + (set! buffer-mode mode) + (when (or (and (eq? old 'block) (memq mode '(none line))) + (and (eq? old 'line) (memq mode '(none)))) + ;; Flush output + (write-it #"" 0 0 #f #f)))]))) + self))) ;; ----------------------------------------