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.
This commit is contained in:
Matthew Flatt
parent
1bd604073a
commit
c33707329c
|
|
@ -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?]
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user