From c53c29d9d8c69f9171e3685249286f3d449e66e1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 24 Nov 2014 17:07:30 -0600 Subject: [PATCH] fix bug in 8027e48 --- .../gui-lib/framework/private/text.rkt | 63 ++++++++----------- .../gui-test/framework/tests/text.rkt | 24 ++++++- 2 files changed, 47 insertions(+), 40 deletions(-) diff --git a/pkgs/gui-pkgs/gui-lib/framework/private/text.rkt b/pkgs/gui-pkgs/gui-lib/framework/private/text.rkt index 9f1e18ef75..224c72d24a 100644 --- a/pkgs/gui-pkgs/gui-lib/framework/private/text.rkt +++ b/pkgs/gui-pkgs/gui-lib/framework/private/text.rkt @@ -2631,7 +2631,7 @@ (handle-evt (alarm-evt (+ last-flush msec-timeout)) (λ (_) - (define-values (viable-bytes remaining-queue remaining-empty?) + (define-values (viable-bytes remaining-queue flush-keep-trying?) (split-queue converter text-to-insert)) ;; we always queue the work here since the ;; always event means no one waits for the callback @@ -2643,13 +2643,14 @@ (define remaining-queue #f) (define viable-bytess (let loop ([q text-to-insert]) - (define-values (viable-bytes next-remaining-queue remaining-empty?) + (define-values (viable-bytes next-remaining-queue flush-keep-trying?) (split-queue converter q)) (cond - [remaining-empty? + [flush-keep-trying? + (cons viable-bytes (loop next-remaining-queue))] + [else (set! remaining-queue next-remaining-queue) - (list viable-bytes)] - [else (cons viable-bytes (loop next-remaining-queue))]))) + (list viable-bytes)]))) (cond [(channel? return-evt/to-insert-chan) (channel-put return-evt/to-insert-chan viable-bytess)] @@ -2682,7 +2683,7 @@ last-flush))] [else (let ([chan (make-channel)]) - (let-values ([(viable-bytes remaining-queue remaining-empty?) + (let-values ([(viable-bytes remaining-queue flush-keep-trying?) (split-queue converter new-text-to-insert)]) (if return-chan (channel-put return-chan viable-bytes) @@ -2849,8 +2850,8 @@ ;; this function must only be called on the output-buffer-thread ;; extracts the viable bytes (and other stuff) from the front of the queue ;; and returns them as strings (and other stuff). - ;; the boolean result indicates that either the queue is empty or the remaining - ;; bytes are not enough to actually build a character. + ;; the boolean result is #t when a flush should try to get more stuff out of the + ;; queue for a second GUI callback (define/private (split-queue converter q) ;; this number based on testing in drracket's REPL @@ -2860,7 +2861,7 @@ ;; take more like 20-60 msec per event (on my laptop) ;; for a bytes containing all (char->integer #\a)s. Random ;; bytes are slower, but probably that's not the common case. - (define too-many-bytes 1000) + (define bytes-limit-for-a-single-go 1000) (define lst (at-queue->list q)) (let loop ([lst lst] [acc null]) @@ -2868,46 +2869,34 @@ [(null? lst) (values (reverse acc) (empty-at-queue) - #t)] + #f)] [else (define-values (front rest) (peel lst)) (cond [(not front) (values (reverse acc) (empty-at-queue) - #t)] + #f)] [(bytes? (car front)) (define the-bytes (car front)) (define key (cdr front)) + (define too-many-bytes? (>= (bytes-length the-bytes) bytes-limit-for-a-single-go)) (cond - [(or (null? rest) - (> (bytes-length the-bytes) too-many-bytes)) + [(or (null? rest) too-many-bytes?) (define remainder-re-enqueued (list->at-queue rest)) - (define-values (tail-queue short-enough-bytes) + (define-values (converted-bytes src-read-amt termination) + (bytes-convert converter the-bytes 0 (min (bytes-length the-bytes) + bytes-limit-for-a-single-go))) + (define new-at-queue (cond - [(< (bytes-length the-bytes) too-many-bytes) - (values remainder-re-enqueued the-bytes)] + [(= src-read-amt (bytes-length the-bytes)) + remainder-re-enqueued] [else - (define leftovers (subbytes the-bytes - too-many-bytes - (bytes-length the-bytes))) - (values (at-enqueue (cons leftovers key) remainder-re-enqueued) - (subbytes the-bytes 0 too-many-bytes))])) - (define-values (converted-bytes src-read-k termination) - (bytes-convert converter short-enough-bytes)) - (cond - [(eq? termination 'aborts) - (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) - (at-enqueue - (cons (subbytes short-enough-bytes - src-read-k - (bytes-length short-enough-bytes)) - key) - tail-queue - (> (bytes-length the-bytes) too-many-bytes)))] - [else - (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) - tail-queue - (> (bytes-length the-bytes) too-many-bytes))])] + (define leftovers (subbytes the-bytes src-read-amt (bytes-length the-bytes))) + (at-enqueue (cons leftovers key) remainder-re-enqueued)])) + (define converted-str (bytes->string/utf-8 (subbytes the-bytes 0 src-read-amt))) + (values (reverse (cons (cons converted-str key) acc)) + new-at-queue + too-many-bytes?)] [else (define-values (converted-bytes src-read-k termination) (bytes-convert converter the-bytes)) diff --git a/pkgs/gui-pkgs/gui-test/framework/tests/text.rkt b/pkgs/gui-pkgs/gui-test/framework/tests/text.rkt index 0ec9e4b7e1..5683624229 100644 --- a/pkgs/gui-pkgs/gui-test/framework/tests/text.rkt +++ b/pkgs/gui-pkgs/gui-test/framework/tests/text.rkt @@ -296,9 +296,10 @@ ;; there is an internal buffer of this size, so writes that are larger and smaller are interesting (define buffer-size 4096) -(let ([big-str (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a)))))] - [non-ascii-str "λαβ一二三四五"]) - +(let () + (define big-str + (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a)))))) + (define non-ascii-str "λαβ一二三四五") (define (do/separate-thread str mtd) (queue-sexp-to-mred `(let* ([t (new (text:ports-mixin text:wide-snip%))] @@ -380,6 +381,23 @@ (flush-output op))))) (when exn (raise exn)) (send t get-text 0 (send t last-position)))))) + + (let ([s "五"]) + (test + 'text:ports%.partial-encoding + (λ (x) (equal? x s)) + (λ () + (define bts (string->bytes/utf-8 s)) + (queue-sexp-to-mred + `(let () + (define t (new (text:ports-mixin text:wide-snip%))) + (define p (send t get-out-port)) + (void (write-bytes (bytes ,(bytes-ref bts 0)) p)) + (flush-output p) + (void (write-bytes ,(subbytes bts 1 (bytes-length bts)) p)) + (flush-output p) + (send t get-text)))))) + ;; the next tests test the interaction when the current ;; thread is the same as the handler thread of the eventspace