fix some problems and inefficiencies in saving and loading wxme streams
svn: r14526 original commit: 119c69e1ad342ff802ab0f00ad566b8a19c410b6
This commit is contained in:
Matthew Flatt
parent
e09ac14ccc
commit
52d97df6c0
|
|
@ -25,3 +25,5 @@
|
|||
(decl editor-put-file set-editor-put-file!)
|
||||
|
||||
(decl popup-menu% set-popup-menu%!)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -611,11 +611,8 @@
|
|||
(and
|
||||
;; Read headers
|
||||
(for/and ([i (in-range num-headers)])
|
||||
(let-boxes ([n 0]
|
||||
[len 0])
|
||||
(begin
|
||||
(send f get n)
|
||||
(send f get-fixed len))
|
||||
(let ([n (send f get-exact)]
|
||||
[len (send f get-fixed-exact)])
|
||||
(and (send f ok?)
|
||||
(or (zero? len)
|
||||
(let ([sclass (send (send f get-s-scl) find-by-map-position f n)])
|
||||
|
|
@ -646,11 +643,10 @@
|
|||
(let ([sclass (if (n . >= . 0)
|
||||
(send (send f get-s-scl) find-by-map-position f n)
|
||||
#f)]) ; -1 => unknown
|
||||
(let-boxes ([len 0])
|
||||
(if (or (not sclass)
|
||||
(not (send sclass get-s-required?)))
|
||||
(send f get-fixed len)
|
||||
(set-box! len -1))
|
||||
(let ([len (if (or (not sclass)
|
||||
(not (send sclass get-s-required?)))
|
||||
(send f get-fixed-exact)
|
||||
-1)])
|
||||
(and (send f ok?)
|
||||
(or (and (zero? len) accum)
|
||||
(and
|
||||
|
|
@ -658,8 +654,7 @@
|
|||
(let ([start (send f tell)])
|
||||
(when (len . >= . 0)
|
||||
(send f set-boundary len))
|
||||
(let-boxes ([style-index 0])
|
||||
(send f get style-index)
|
||||
(let ([style-index (send f get-exact)])
|
||||
(let ([snip (send sclass read f)])
|
||||
(and
|
||||
snip
|
||||
|
|
@ -1337,7 +1332,7 @@
|
|||
(editor-get-file "choose a file" (extract-parent) #f path))
|
||||
|
||||
(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))
|
||||
|
||||
(def/public (set-load-overwrites-styles [any? b?])
|
||||
|
|
@ -1419,7 +1414,7 @@
|
|||
(let ([sclass (snip->snipclass snip)])
|
||||
(unless sclass
|
||||
(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
|
||||
(send f put (send f do-map-position sclass))
|
||||
(let ([header-start (send f tell)])
|
||||
|
|
|
|||
|
|
@ -99,7 +99,11 @@
|
|||
(def/public (read-bytes [bytes? v]
|
||||
[exact-nonnegative-integer? [start 0]]
|
||||
[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%
|
||||
(super-new)
|
||||
|
|
@ -116,6 +120,8 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define mz:read-byte read-byte)
|
||||
|
||||
(defclass editor-stream-in-port-base% editor-stream-in-base%
|
||||
(init-field port)
|
||||
(super-new)
|
||||
|
|
@ -137,7 +143,11 @@
|
|||
(let ([r (read-bytes! v port start end)])
|
||||
(if (eof-object? r)
|
||||
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%
|
||||
(super-new))
|
||||
|
|
@ -182,6 +192,8 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define in-read-byte (generic editor-stream-in-base% read-byte))
|
||||
|
||||
(defclass editor-stream-in% editor-stream%
|
||||
(init-rest args)
|
||||
|
||||
|
|
@ -216,48 +228,50 @@
|
|||
(define (bad!) (set! is-bad? #t) 0)
|
||||
(if is-bad?
|
||||
0
|
||||
(let ([s (make-bytes 1)])
|
||||
(let loop ([prev-byte 0])
|
||||
(if (not (= 1 (send f read-bytes s)))
|
||||
(let loop ([prev-byte 0])
|
||||
(let ([b (send-generic f in-read-byte)])
|
||||
(if (not b)
|
||||
(bad!)
|
||||
(let ([b (bytes-ref s 0)])
|
||||
(case (integer->char b)
|
||||
[(#\#)
|
||||
(let ([pos (send f tell)])
|
||||
(if (and (= 1 (send f read-bytes s))
|
||||
(= (bytes-ref s 0) (char->integer #\|)))
|
||||
;; skip to end of comment
|
||||
(let cloop ([saw-bar? #f]
|
||||
[saw-hash? #f]
|
||||
[nesting 0])
|
||||
(if (not (= 1 (send f read-bytes s)))
|
||||
(case (integer->char b)
|
||||
[(#\#)
|
||||
(let ([pos (send f tell)]
|
||||
[b (send-generic f in-read-byte)])
|
||||
(if (and b
|
||||
(= b (char->integer #\|)))
|
||||
;; skip to end of comment
|
||||
(let cloop ([saw-bar? #f]
|
||||
[saw-hash? #f]
|
||||
[nesting 0])
|
||||
(let ([b (send-generic f in-read-byte)])
|
||||
(if (not b)
|
||||
(bad!)
|
||||
(cond
|
||||
[(and saw-bar? (= (bytes-ref s 0) (char->integer #\#)))
|
||||
[(and saw-bar? (= b (char->integer #\#)))
|
||||
(if (zero? nesting)
|
||||
(loop (char->integer #\space))
|
||||
(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))]
|
||||
[else (cloop (= (bytes-ref s 0) (char->integer #\|))
|
||||
(= (bytes-ref s 0) (char->integer #\#))
|
||||
nesting)])))
|
||||
(begin
|
||||
(send f seek pos)
|
||||
(char->integer #\#))))]
|
||||
[(#\;)
|
||||
;; skip to end of comment
|
||||
(let cloop ()
|
||||
(if (not (= 1 (send f read-bytes s)))
|
||||
[else (cloop (= b (char->integer #\|))
|
||||
(= b (char->integer #\#))
|
||||
nesting)]))))
|
||||
(begin
|
||||
(send f seek pos)
|
||||
(char->integer #\#))))]
|
||||
[(#\;)
|
||||
;; skip to end of comment
|
||||
(let cloop ()
|
||||
(let ([b (send-generic f in-read-byte)])
|
||||
(if (not b)
|
||||
(bad!)
|
||||
(if (or (= (bytes-ref s 0) (char->integer #\newline))
|
||||
(= (bytes-ref s 0) (char->integer #\return)))
|
||||
(if (or (= b (char->integer #\newline))
|
||||
(= b (char->integer #\return)))
|
||||
(loop (char->integer #\space))
|
||||
(cloop))))]
|
||||
[else
|
||||
(if (char-whitespace? (integer->char b))
|
||||
(loop b)
|
||||
b)])))))))
|
||||
(cloop)))))]
|
||||
[else
|
||||
(if (char-whitespace? (integer->char b))
|
||||
(loop b)
|
||||
b)]))))))
|
||||
|
||||
(define/private (skip-whitespace [buf #f])
|
||||
(let ([c (do-skip-whitespace)])
|
||||
|
|
@ -270,9 +284,8 @@
|
|||
[(char-whitespace? (integer->char b)) #t]
|
||||
[(= b (char->integer #\#))
|
||||
(let ([pos (send f tell)]
|
||||
[s (make-bytes 1)])
|
||||
(send f read-bytes s)
|
||||
(let ([d? (= (bytes-ref s 0) (char->integer #\|))])
|
||||
[b (send-generic f in-read-byte)])
|
||||
(let ([d? (= b (char->integer #\|))])
|
||||
(send f seek (if d? (sub1 pos) pos))
|
||||
d?))]
|
||||
[(= b (char->integer #\;))
|
||||
|
|
@ -284,36 +297,43 @@
|
|||
(let ([c0 (skip-whitespace)])
|
||||
(if (check-boundary)
|
||||
(if get-exact? 0 0.0)
|
||||
(let* ([s (make-bytes 1)]
|
||||
[l (cons (integer->char c0)
|
||||
(let loop ([counter 50])
|
||||
(if (zero? counter)
|
||||
null
|
||||
(if (= 1 (send f read-bytes s))
|
||||
(let ([s (bytes-ref s 0)])
|
||||
(if (is-delim? s)
|
||||
null
|
||||
(cons (integer->char s)
|
||||
(loop (sub1 counter)))))
|
||||
null))))])
|
||||
(let* ([l
|
||||
;; As fast path, accum integer result
|
||||
(let loop ([counter 50][c c0][v 0])
|
||||
(if (zero? counter)
|
||||
null
|
||||
(if (or (not c)
|
||||
(is-delim? c))
|
||||
(or v null)
|
||||
(let ([rest (loop (sub1 counter)
|
||||
(send-generic f in-read-byte)
|
||||
(and v
|
||||
(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)
|
||||
(let ([n (string->number (list->string l))])
|
||||
(let ([n (if (exact-integer? l)
|
||||
l
|
||||
(string->number (list->string l)))])
|
||||
(cond
|
||||
[(or (not n)
|
||||
(not (real? n))
|
||||
(and get-exact? (not (exact-integer? n))))
|
||||
(set! is-bad? #t)
|
||||
(if get-exact? 0 0.0)]
|
||||
[get-exact? n]
|
||||
[(and get-exact? (exact-integer? n)) n]
|
||||
[(real? n) (exact->inexact n)]
|
||||
[else
|
||||
(exact->inexact n)]))))))
|
||||
(set! is-bad? #t)
|
||||
(if get-exact? 0 0.0)]))))))
|
||||
|
||||
(define/private (get-a-string limit recur?)
|
||||
(let* ([orig-len (if recur?
|
||||
(if (limit . < . 16)
|
||||
limit
|
||||
16)
|
||||
(get-exact))]
|
||||
(let ([v (get-exact)])
|
||||
(if (check-boundary)
|
||||
0
|
||||
v)))]
|
||||
[buf (make-bytes 32)]
|
||||
[fail (lambda ()
|
||||
(set! is-bad? #t)
|
||||
|
|
@ -447,20 +467,22 @@
|
|||
(success)
|
||||
(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])
|
||||
(let ([v (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)))])
|
||||
(set-box! vb v)))
|
||||
(set-box! vb (get-fixed-exact)))
|
||||
|
||||
#|
|
||||
integer format specified by first byte:
|
||||
|
|
@ -569,7 +591,7 @@
|
|||
#t
|
||||
(cond
|
||||
[(and (pair? boundaries)
|
||||
(items . > . (car boundaries)))
|
||||
(items . >= . (car boundaries)))
|
||||
(set! is-bad? #t)
|
||||
(error 'editor-stream-in%
|
||||
"overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))]
|
||||
|
|
@ -647,6 +669,7 @@
|
|||
(bytes-append spc
|
||||
(make-bytes (- 11 (string-length s)) (char->integer #\space))
|
||||
(string->bytes/latin-1 s))))
|
||||
(set! col new-col)
|
||||
(set! items (add1 items)))
|
||||
this)
|
||||
|
||||
|
|
|
|||
|
|
@ -768,12 +768,15 @@
|
|||
(expect (send fi2 tell) 10)
|
||||
|
||||
(send fi2 jump-to 3)
|
||||
(send fi2 set-boundary 5)
|
||||
(send fi2 set-boundary 2)
|
||||
(expect (send fi2 get-unterminated-bytes) #"hi")
|
||||
(send fi2 jump-to 3)
|
||||
(expect (send fi2 ok?) #t)
|
||||
(send fi2 set-boundary 4)
|
||||
(expect (send fi2 get-unterminated-bytes) #"")
|
||||
(expect (send fi2 tell) 3)
|
||||
(send fi2 set-boundary 1)
|
||||
(expect (with-handlers ([values (lambda (exn) #"")])
|
||||
(send fi2 get-unterminated-bytes))
|
||||
#"")
|
||||
(expect (send fi2 ok?) #f)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user