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

fix some problems and inefficiencies in saving and loading wxme streams

Browse Source 
svn: r14526

original commit: 119c69e1ad342ff802ab0f00ad566b8a19c410b6
This commit is contained in:
Matthew Flatt 2009-04-15 22:27:43 +00:00
parent e09ac14ccc
commit 52d97df6c0
4 changed files with 113 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/wxme/cycle.ss
View File

@ -25,3 +25,5 @@
(decl editor-put-file set-editor-put-file!) (decl editor-put-file set-editor-put-file!)
(decl popup-menu% set-popup-menu%!) (decl popup-menu% set-popup-menu%!)

23
collects/mred/private/wxme/editor.ss
View File

@ -611,11 +611,8 @@
(and (and
;; Read headers ;; Read headers
(for/and ([i (in-range num-headers)]) (for/and ([i (in-range num-headers)])
(let-boxes ([n 0] (let ([n (send f get-exact)]
[len 0]) [len (send f get-fixed-exact)])
(begin
(send f get n)
(send f get-fixed len))
(and (send f ok?) (and (send f ok?)
(or (zero? len) (or (zero? len)
(let ([sclass (send (send f get-s-scl) find-by-map-position f n)]) (let ([sclass (send (send f get-s-scl) find-by-map-position f n)])
@ -646,11 +643,10 @@
(let ([sclass (if (n . >= . 0) (let ([sclass (if (n . >= . 0)
(send (send f get-s-scl) find-by-map-position f n) (send (send f get-s-scl) find-by-map-position f n)
#f)]) ; -1 => unknown #f)]) ; -1 => unknown
(let-boxes ([len 0]) (let ([len (if (or (not sclass)
(if (or (not sclass) (not (send sclass get-s-required?)))
(not (send sclass get-s-required?))) (send f get-fixed-exact)
(send f get-fixed len) -1)])
(set-box! len -1))
(and (send f ok?) (and (send f ok?)
(or (and (zero? len) accum) (or (and (zero? len) accum)
(and (and
@ -658,8 +654,7 @@
(let ([start (send f tell)]) (let ([start (send f tell)])
(when (len . >= . 0) (when (len . >= . 0)
(send f set-boundary len)) (send f set-boundary len))
(let-boxes ([style-index 0]) (let ([style-index (send f get-exact)])
(send f get style-index)
(let ([snip (send sclass read f)]) (let ([snip (send sclass read f)])
(and (and
snip snip
@ -1337,7 +1332,7 @@
(editor-get-file "choose a file" (extract-parent) #f path)) (editor-get-file "choose a file" (extract-parent) #f path))
(def/public (put-file [(make-or-false path-string?) dir] (def/public (put-file [(make-or-false path-string?) dir]
[(make-or-false string?) suggested-name]) [(make-or-false path-string?) suggested-name])
(editor-put-file "save file as" (extract-parent) dir suggested-name)) (editor-put-file "save file as" (extract-parent) dir suggested-name))
(def/public (set-load-overwrites-styles [any? b?]) (def/public (set-load-overwrites-styles [any? b?])
@ -1419,7 +1414,7 @@
(let ([sclass (snip->snipclass snip)]) (let ([sclass (snip->snipclass snip)])
(unless sclass (unless sclass
(error 'write-snips-to-file "snip has no snipclass")) (error 'write-snips-to-file "snip has no snipclass"))
(if (send f do-get-header-flag sclass) (if (not (send f do-get-header-flag sclass))
(begin (begin
(send f put (send f do-map-position sclass)) (send f put (send f do-map-position sclass))
(let ([header-start (send f tell)]) (let ([header-start (send f tell)])

169
collects/mred/private/wxme/stream.ss
View File

@ -99,7 +99,11 @@
(def/public (read-bytes [bytes? v] (def/public (read-bytes [bytes? v]
[exact-nonnegative-integer? [start 0]] [exact-nonnegative-integer? [start 0]]
[exact-nonnegative-integer? [end (bytes-length v)]]) [exact-nonnegative-integer? [end (bytes-length v)]])
0)) 0)
(def/public (read-byte)
(let ([s (make-bytes 1)])
(and (= 1 (read-bytes s 0 1))
(bytes-ref s 0)))))
(defclass editor-stream-out-base% object% (defclass editor-stream-out-base% object%
(super-new) (super-new)
@ -116,6 +120,8 @@
;; ---------------------------------------- ;; ----------------------------------------
(define mz:read-byte read-byte)
(defclass editor-stream-in-port-base% editor-stream-in-base% (defclass editor-stream-in-port-base% editor-stream-in-base%
(init-field port) (init-field port)
(super-new) (super-new)
@ -137,7 +143,11 @@
(let ([r (read-bytes! v port start end)]) (let ([r (read-bytes! v port start end)])
(if (eof-object? r) (if (eof-object? r)
0 0
r)))) r)))
(def/override (read-byte)
(let ([v (mz:read-byte port)])
(if (eof-object? v) #f v))))
(defclass editor-stream-in-file-base% editor-stream-in-port-base% (defclass editor-stream-in-file-base% editor-stream-in-port-base%
(super-new)) (super-new))
@ -182,6 +192,8 @@
;; ---------------------------------------- ;; ----------------------------------------
(define in-read-byte (generic editor-stream-in-base% read-byte))
(defclass editor-stream-in% editor-stream% (defclass editor-stream-in% editor-stream%
(init-rest args) (init-rest args)
@ -216,48 +228,50 @@
(define (bad!) (set! is-bad? #t) 0) (define (bad!) (set! is-bad? #t) 0)
(if is-bad? (if is-bad?
0 0
(let ([s (make-bytes 1)]) (let loop ([prev-byte 0])
(let loop ([prev-byte 0]) (let ([b (send-generic f in-read-byte)])
(if (not (= 1 (send f read-bytes s))) (if (not b)
(bad!) (bad!)
(let ([b (bytes-ref s 0)]) (case (integer->char b)
(case (integer->char b) [(#\#)
[(#\#) (let ([pos (send f tell)]
(let ([pos (send f tell)]) [b (send-generic f in-read-byte)])
(if (and (= 1 (send f read-bytes s)) (if (and b
(= (bytes-ref s 0) (char->integer #\|))) (= b (char->integer #\|)))
;; skip to end of comment ;; skip to end of comment
(let cloop ([saw-bar? #f] (let cloop ([saw-bar? #f]
[saw-hash? #f] [saw-hash? #f]
[nesting 0]) [nesting 0])
(if (not (= 1 (send f read-bytes s))) (let ([b (send-generic f in-read-byte)])
(if (not b)
(bad!) (bad!)
(cond (cond
[(and saw-bar? (= (bytes-ref s 0) (char->integer #\#))) [(and saw-bar? (= b (char->integer #\#)))
(if (zero? nesting) (if (zero? nesting)
(loop (char->integer #\space)) (loop (char->integer #\space))
(cloop #f #f (sub1 nesting)))] (cloop #f #f (sub1 nesting)))]
[(and saw-hash? (= (bytes-ref s 0) (char->integer #\|))) [(and saw-hash? (= b (char->integer #\|)))
(cloop #t #f (add1 nesting))] (cloop #t #f (add1 nesting))]
[else (cloop (= (bytes-ref s 0) (char->integer #\|)) [else (cloop (= b (char->integer #\|))
(= (bytes-ref s 0) (char->integer #\#)) (= b (char->integer #\#))
nesting)]))) nesting)]))))
(begin (begin
(send f seek pos) (send f seek pos)
(char->integer #\#))))] (char->integer #\#))))]
[(#\;) [(#\;)
;; skip to end of comment ;; skip to end of comment
(let cloop () (let cloop ()
(if (not (= 1 (send f read-bytes s))) (let ([b (send-generic f in-read-byte)])
(if (not b)
(bad!) (bad!)
(if (or (= (bytes-ref s 0) (char->integer #\newline)) (if (or (= b (char->integer #\newline))
(= (bytes-ref s 0) (char->integer #\return))) (= b (char->integer #\return)))
(loop (char->integer #\space)) (loop (char->integer #\space))
(cloop))))] (cloop)))))]
[else [else
(if (char-whitespace? (integer->char b)) (if (char-whitespace? (integer->char b))
(loop b) (loop b)
b)]))))))) b)]))))))
(define/private (skip-whitespace [buf #f]) (define/private (skip-whitespace [buf #f])
(let ([c (do-skip-whitespace)]) (let ([c (do-skip-whitespace)])
@ -270,9 +284,8 @@
[(char-whitespace? (integer->char b)) #t] [(char-whitespace? (integer->char b)) #t]
[(= b (char->integer #\#)) [(= b (char->integer #\#))
(let ([pos (send f tell)] (let ([pos (send f tell)]
[s (make-bytes 1)]) [b (send-generic f in-read-byte)])
(send f read-bytes s) (let ([d? (= b (char->integer #\|))])
(let ([d? (= (bytes-ref s 0) (char->integer #\|))])
(send f seek (if d? (sub1 pos) pos)) (send f seek (if d? (sub1 pos) pos))
d?))] d?))]
[(= b (char->integer #\;)) [(= b (char->integer #\;))
@ -284,36 +297,43 @@
(let ([c0 (skip-whitespace)]) (let ([c0 (skip-whitespace)])
(if (check-boundary) (if (check-boundary)
(if get-exact? 0 0.0) (if get-exact? 0 0.0)
(let* ([s (make-bytes 1)] (let* ([l
[l (cons (integer->char c0) ;; As fast path, accum integer result
(let loop ([counter 50]) (let loop ([counter 50][c c0][v 0])
(if (zero? counter) (if (zero? counter)
null null
(if (= 1 (send f read-bytes s)) (if (or (not c)
(let ([s (bytes-ref s 0)]) (is-delim? c))
(if (is-delim? s) (or v null)
null (let ([rest (loop (sub1 counter)
(cons (integer->char s) (send-generic f in-read-byte)
(loop (sub1 counter))))) (and v
null))))]) (c . >= . (char->integer #\0))
(c . <= . (char->integer #\9))
(+ (* v 10) (- c (char->integer #\0)))))])
(if (exact-integer? rest)
rest
(cons (integer->char c) rest))))))])
(inc-item-count) (inc-item-count)
(let ([n (string->number (list->string l))]) (let ([n (if (exact-integer? l)
l
(string->number (list->string l)))])
(cond (cond
[(or (not n) [(and get-exact? (exact-integer? n)) n]
(not (real? n)) [(real? n) (exact->inexact n)]
(and get-exact? (not (exact-integer? n))))
(set! is-bad? #t)
(if get-exact? 0 0.0)]
[get-exact? n]
[else [else
(exact->inexact n)])))))) (set! is-bad? #t)
(if get-exact? 0 0.0)]))))))
(define/private (get-a-string limit recur?) (define/private (get-a-string limit recur?)
(let* ([orig-len (if recur? (let* ([orig-len (if recur?
(if (limit . < . 16) (if (limit . < . 16)
limit limit
16) 16)
(get-exact))] (let ([v (get-exact)])
(if (check-boundary)
0
v)))]
[buf (make-bytes 32)] [buf (make-bytes 32)]
[fail (lambda () [fail (lambda ()
(set! is-bad? #t) (set! is-bad? #t)
@ -447,20 +467,22 @@
(success) (success)
(loop))))])))) (loop))))]))))
(def/public (get-fixed-exact)
(if (check-boundary)
0
(if (read-version . < . 8)
(let ([buf (make-bytes 4)])
(send f read-bytes buf)
(integer-bytes->integer
buf
#t
(if (= read-version 1)
(system-big-endian?)
#t)))
(get-exact))))
(def/public (get-fixed [box? vb]) (def/public (get-fixed [box? vb])
(let ([v (if (check-boundary) (set-box! vb (get-fixed-exact)))
0
(if (read-version . < . 8)
(let ([buf (make-bytes 4)])
(send f read-bytes buf)
(integer-bytes->integer
buf
#t
(if (= read-version 1)
(system-big-endian?)
#t)))
(get-exact)))])
(set-box! vb v)))
#| #|
integer format specified by first byte: integer format specified by first byte:
@ -569,7 +591,7 @@
#t #t
(cond (cond
[(and (pair? boundaries) [(and (pair? boundaries)
(items . > . (car boundaries))) (items . >= . (car boundaries)))
(set! is-bad? #t) (set! is-bad? #t)
(error 'editor-stream-in% (error 'editor-stream-in%
"overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))] "overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))]
@ -647,6 +669,7 @@
(bytes-append spc (bytes-append spc
(make-bytes (- 11 (string-length s)) (char->integer #\space)) (make-bytes (- 11 (string-length s)) (char->integer #\space))
(string->bytes/latin-1 s)))) (string->bytes/latin-1 s))))
(set! col new-col)
(set! items (add1 items))) (set! items (add1 items)))
this) this)

9
collects/tests/mred/wxme.ss
View File

@ -768,12 +768,15 @@
(expect (send fi2 tell) 10) (expect (send fi2 tell) 10)
(send fi2 jump-to 3) (send fi2 jump-to 3)
(send fi2 set-boundary 5) (send fi2 set-boundary 2)
(expect (send fi2 get-unterminated-bytes) #"hi") (expect (send fi2 get-unterminated-bytes) #"hi")
(send fi2 jump-to 3) (send fi2 jump-to 3)
(expect (send fi2 ok?) #t) (expect (send fi2 ok?) #t)
(send fi2 set-boundary 4) (expect (send fi2 tell) 3)
(expect (send fi2 get-unterminated-bytes) #"") (send fi2 set-boundary 1)
(expect (with-handlers ([values (lambda (exn) #"")])
(send fi2 get-unterminated-bytes))
#"")
(expect (send fi2 ok?) #f) (expect (send fi2 ok?) #f)
;; ---------------------------------------- ;; ----------------------------------------