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

fix bug in 8027e48

Browse Source 
original commit: c53c29d9d8c69f9171e3685249286f3d449e66e1
This commit is contained in:
Robby Findler 2014-11-24 17:07:30 -06:00
parent 7a1cb5ed11
commit 0e2a9abda1
2 changed files with 47 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
pkgs/gui-pkgs/gui-lib/framework/private/text.rkt
View File

@ -2631,7 +2631,7 @@
(handle-evt (handle-evt
(alarm-evt (+ last-flush msec-timeout)) (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)) (split-queue converter text-to-insert))
;; we always queue the work here since the ;; we always queue the work here since the
;; always event means no one waits for the callback ;; always event means no one waits for the callback
@ -2643,13 +2643,14 @@
(define remaining-queue #f) (define remaining-queue #f)
(define viable-bytess (define viable-bytess
(let loop ([q text-to-insert]) (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)) (split-queue converter q))
(cond (cond
[remaining-empty? [flush-keep-trying?
(cons viable-bytes (loop next-remaining-queue))]
[else
(set! remaining-queue next-remaining-queue) (set! remaining-queue next-remaining-queue)
(list viable-bytes)] (list viable-bytes)])))
[else (cons viable-bytes (loop next-remaining-queue))])))
(cond (cond
[(channel? return-evt/to-insert-chan) [(channel? return-evt/to-insert-chan)
(channel-put return-evt/to-insert-chan viable-bytess)] (channel-put return-evt/to-insert-chan viable-bytess)]
@ -2682,7 +2683,7 @@
last-flush))] last-flush))]
[else [else
(let ([chan (make-channel)]) (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)]) (split-queue converter new-text-to-insert)])
(if return-chan (if return-chan
(channel-put return-chan viable-bytes) (channel-put return-chan viable-bytes)
@ -2849,8 +2850,8 @@
;; this function must only be called on the output-buffer-thread ;; this function must only be called on the output-buffer-thread
;; extracts the viable bytes (and other stuff) from the front of the queue ;; extracts the viable bytes (and other stuff) from the front of the queue
;; and returns them as strings (and other stuff). ;; and returns them as strings (and other stuff).
;; the boolean result indicates that either the queue is empty or the remaining ;; the boolean result is #t when a flush should try to get more stuff out of the
;; bytes are not enough to actually build a character. ;; queue for a second GUI callback
(define/private (split-queue converter q) (define/private (split-queue converter q)
;; this number based on testing in drracket's REPL ;; this number based on testing in drracket's REPL
@ -2860,7 +2861,7 @@
;; take more like 20-60 msec per event (on my laptop) ;; take more like 20-60 msec per event (on my laptop)
;; for a bytes containing all (char->integer #\a)s. Random ;; for a bytes containing all (char->integer #\a)s. Random
;; bytes are slower, but probably that's not the common case. ;; 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)) (define lst (at-queue->list q))
(let loop ([lst lst] [acc null]) (let loop ([lst lst] [acc null])
@ -2868,46 +2869,34 @@
[(null? lst) [(null? lst)
(values (reverse acc) (values (reverse acc)
(empty-at-queue) (empty-at-queue)
#t)] #f)]
[else [else
(define-values (front rest) (peel lst)) (define-values (front rest) (peel lst))
(cond (cond
[(not front) (values (reverse acc) [(not front) (values (reverse acc)
(empty-at-queue) (empty-at-queue)
#t)] #f)]
[(bytes? (car front)) [(bytes? (car front))
(define the-bytes (car front)) (define the-bytes (car front))
(define key (cdr front)) (define key (cdr front))
(define too-many-bytes? (>= (bytes-length the-bytes) bytes-limit-for-a-single-go))
(cond (cond
[(or (null? rest) [(or (null? rest) too-many-bytes?)
(> (bytes-length the-bytes) too-many-bytes))
(define remainder-re-enqueued (list->at-queue rest)) (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 (cond
[(< (bytes-length the-bytes) too-many-bytes) [(= src-read-amt (bytes-length the-bytes))
(values remainder-re-enqueued the-bytes)] remainder-re-enqueued]
[else [else
(define leftovers (subbytes the-bytes (define leftovers (subbytes the-bytes src-read-amt (bytes-length the-bytes)))
too-many-bytes (at-enqueue (cons leftovers key) remainder-re-enqueued)]))
(bytes-length the-bytes))) (define converted-str (bytes->string/utf-8 (subbytes the-bytes 0 src-read-amt)))
(values (at-enqueue (cons leftovers key) remainder-re-enqueued) (values (reverse (cons (cons converted-str key) acc))
(subbytes the-bytes 0 too-many-bytes))])) new-at-queue
(define-values (converted-bytes src-read-k termination) too-many-bytes?)]
(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))])]
[else [else
(define-values (converted-bytes src-read-k termination) (define-values (converted-bytes src-read-k termination)
(bytes-convert converter the-bytes)) (bytes-convert converter the-bytes))

24
pkgs/gui-pkgs/gui-test/framework/tests/text.rkt
View File

@ -296,9 +296,10 @@
;; there is an internal buffer of this size, so writes that are larger and smaller are interesting ;; there is an internal buffer of this size, so writes that are larger and smaller are interesting
(define buffer-size 4096) (define buffer-size 4096)
(let ([big-str (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a)))))] (let ()
[non-ascii-str "λαβ一二三四五"]) (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) (define (do/separate-thread str mtd)
(queue-sexp-to-mred (queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))] `(let* ([t (new (text:ports-mixin text:wide-snip%))]
@ -381,6 +382,23 @@
(when exn (raise exn)) (when exn (raise exn))
(send t get-text 0 (send t last-position)))))) (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 ;; the next tests test the interaction when the current
;; thread is the same as the handler thread of the eventspace ;; thread is the same as the handler thread of the eventspace
;; where the text was created ;; where the text was created