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

racket/port: add a flushing tidy callback for reencode-output-port

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2014-05-07 07:27:46 -06:00
parent 1bd604073a
commit c33707329c
3 changed files with 92 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/racket-pkgs/racket-doc/scribblings/reference/port-lib.scrbl
View File

@ -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 The resulting output port does not support atomic writes. An explicit
flush or special-write to the output port can hang if the most 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?] @defproc[(dup-input-port [in input-port?]

82
pkgs/racket-pkgs/racket-test/tests/racket/portlib.rktl
View File

@ -746,47 +746,53 @@
(void)) (void))
;; Check buffer modes: ;; Check buffer modes:
(let ([i (open-input-string "abc")] (let ()
[o (open-output-string)]) (define (check-buffering flush-output)
(test #f file-stream-buffer-mode i) (let ([i (open-input-string "abc")]
(test #f file-stream-buffer-mode o) [o (open-output-string)])
(let ([ei (reencode-input-port i "UTF-8")] (test #f file-stream-buffer-mode i)
[eo (reencode-output-port o "UTF-8")]) (test #f file-stream-buffer-mode o)
(test 'none file-stream-buffer-mode ei) (let ([ei (reencode-input-port i "UTF-8")]
(test 'block file-stream-buffer-mode eo) [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 10 eo)
(test (void) display 12 eo) (test (void) display 12 eo)
(test (void) newline eo) (test (void) newline eo)
(test #"" get-output-bytes o) (test #"" get-output-bytes o)
(test (void) flush-output eo) (test (void) flush-output eo)
(test #"1012\n" get-output-bytes o) (test #"1012\n" get-output-bytes o)
(test (void) file-stream-buffer-mode eo 'line) (test (void) file-stream-buffer-mode eo 'line)
(test 'line file-stream-buffer-mode eo) (test 'line file-stream-buffer-mode eo)
(test (void) display 13 eo) (test (void) display 13 eo)
(test #"1012\n" get-output-bytes o) (test #"1012\n" get-output-bytes o)
(test (void) newline eo) (test (void) newline eo)
(test #"1012\n13\n" get-output-bytes o) (test #"1012\n13\n" get-output-bytes o)
(test (void) flush-output eo) (test (void) flush-output eo)
(test #"1012\n13\n" get-output-bytes o) (test #"1012\n13\n" get-output-bytes o)
(test (void) display 14 eo) (test (void) display 14 eo)
(test #"1012\n13\n" get-output-bytes o) (test #"1012\n13\n" get-output-bytes o)
(test (void) file-stream-buffer-mode eo 'none) (test (void) file-stream-buffer-mode eo 'none)
(test #"1012\n13\n14" get-output-bytes o) (test #"1012\n13\n14" get-output-bytes o)
(test 'none file-stream-buffer-mode eo) (test 'none file-stream-buffer-mode eo)
(test (void) display 15 eo) (test (void) display 15 eo)
(test #"1012\n13\n1415" get-output-bytes o) (test #"1012\n13\n1415" get-output-bytes o)
(test #\a read-char ei) (test #\a read-char ei)
(test #\b peek-char i) (test #\b peek-char i)
(test (void) file-stream-buffer-mode ei 'block) (test (void) file-stream-buffer-mode ei 'block)
(test 'block file-stream-buffer-mode ei) (test 'block file-stream-buffer-mode ei)
(test #\b read-char ei) (test #\b read-char ei)
(test eof peek-char i) (test eof peek-char i)
(test #\c read-char ei) (test #\c read-char ei)
(test eof 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 (err/rt-test
(port->bytes (reencode-input-port (open-input-bytes #"\xFF\xFF") "utf-8")) (port->bytes (reencode-input-port (open-input-bytes #"\xFF\xFF") "utf-8"))

69
racket/collects/racket/port.rkt
View File

@ -1636,7 +1636,10 @@
[out-end 0] [out-end 0]
[buffer-mode (or (file-stream-buffer-mode port) 'block)] [buffer-mode (or (file-stream-buffer-mode port) 'block)]
[debuffer-buf #f] [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)) (define-values (buffered-r buffered-w) (make-pipe 4096))
;; The main writing entry point: ;; The main writing entry point:
@ -1649,7 +1652,9 @@
(flush-buffer-pipe #f enable-break?) (flush-buffer-pipe #f enable-break?)
(flush-some #f enable-break?) (flush-some #f enable-break?)
(if (buffer-flushed?) (if (buffer-flushed?)
0 (begin
(buffering! #f)
0)
(write-it s start end no-buffer&block? enable-break?))] (write-it s start end no-buffer&block? enable-break?))]
[no-buffer&block? [no-buffer&block?
(case (flush-all #t enable-break?) (case (flush-all #t enable-break?)
@ -1671,6 +1676,7 @@
[(and (eq? buffer-mode 'block) [(and (eq? buffer-mode 'block)
(zero? (pipe-content-length buffered-r))) (zero? (pipe-content-length buffered-r)))
;; The port system can buffer to a pipe faster, so give it a pipe. ;; The port system can buffer to a pipe faster, so give it a pipe.
(buffering! #t)
buffered-w] buffered-w]
[else [else
;; Flush/buffer from pipe, first: ;; Flush/buffer from pipe, first:
@ -1687,6 +1693,7 @@
(write-it s start end #f enable-break?) (write-it s start end #f enable-break?)
;; Buffer and report success: ;; Buffer and report success:
(begin (begin
(buffering! #t)
(bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2)) (bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2))
(set! out-end (+ cnt2 out-end)) (set! out-end (+ cnt2 out-end))
(case buffer-mode (case buffer-mode
@ -1837,7 +1844,9 @@
[orig-out-end out-end]) [orig-out-end out-end])
(flush-some non-block? enable-break?) (flush-some non-block? enable-break?)
(if (buffer-flushed?) (if (buffer-flushed?)
'done (begin
(buffering! #f)
'done)
;; Couldn't flush everything. One possibility is that we need ;; Couldn't flush everything. One possibility is that we need
;; more bytes to convert before a flush. ;; more bytes to convert before a flush.
(if (and orig-none-ready? (if (and orig-none-ready?
@ -1857,6 +1866,14 @@
(= out-start out-end) (= out-start out-end)
(zero? (pipe-content-length buffered-r)))) (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. ;; Try to flush immediately a certain number of bytes.
;; we've already converted them, so we have to keep ;; we've already converted them, so we have to keep
;; the bytes in any case. ;; the bytes in any case.
@ -1913,28 +1930,30 @@
"could not create converter from ~e to UTF-8" "could not create converter from ~e to UTF-8"
encoding)) encoding))
(make-output-port (set! self
name (make-output-port
port name
write-it port
(lambda () write-it
;; Flush output (lambda ()
(write-it #"" 0 0 #f #f) ;; Flush output
(when close? (flush-output self)
(close-output-port port)) (when close?
(bytes-close-converter c)) (close-output-port port))
write-special-it (bytes-close-converter c))
#f #f write-special-it
#f void #f #f
1 #f void
(case-lambda 1
[() buffer-mode] (case-lambda
[(mode) (let ([old buffer-mode]) [() buffer-mode]
(set! buffer-mode mode) [(mode) (let ([old buffer-mode])
(when (or (and (eq? old 'block) (memq mode '(none line))) (set! buffer-mode mode)
(and (eq? old 'line) (memq mode '(none)))) (when (or (and (eq? old 'block) (memq mode '(none line)))
;; Flush output (and (eq? old 'line) (memq mode '(none))))
(write-it #"" 0 0 #f #f)))]))))) ;; Flush output
(write-it #"" 0 0 #f #f)))])))
self)))
;; ---------------------------------------- ;; ----------------------------------------