fix some problems and inefficiencies in saving and loading wxme streams
svn: r14526
This commit is contained in:
Matthew Flatt
parent
0574391f0d
commit
119c69e1ad
|
|
@ -8,6 +8,7 @@
|
|||
browser/external
|
||||
browser/tool
|
||||
scheme/base
|
||||
scheme/contract
|
||||
scheme/class
|
||||
scheme/gui/base
|
||||
net/url
|
||||
|
|
@ -26,8 +27,8 @@ The @schememodname[browser] library provides the following
|
|||
procedures and classes for parsing and viewing HTML files. The
|
||||
@schememodname[browser/htmltext] library provides a simplified
|
||||
interface for rendering to a subclass of the MrEd @scheme[text%]
|
||||
class. The [browser/external] library provides utilities for launching
|
||||
an external browser (such as Firefox).
|
||||
class. The @schememodname[browser/external] library provides utilities
|
||||
for launching an external browser (such as Firefox).
|
||||
|
||||
@section[#:tag "browser"]{Browser}
|
||||
|
||||
|
|
@ -80,7 +81,7 @@ examples). The Scheme code is executed through @scheme[eval].
|
|||
The @(litchar "MZSCHEME") forms are disabled unless the web page is a
|
||||
@(litchar "file:") url that points into the @scheme[doc] collection.
|
||||
|
||||
@defproc[(open-url [url (or/c url? string? input-port?)]) void?]{
|
||||
@defproc[(open-url [url (or/c url? string? input-port?)]) (is-a?/c hyper-frame%)]{
|
||||
Opens the given url
|
||||
in a vanilla browser frame and returns
|
||||
the frame. The frame is an instance of
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -315,11 +315,9 @@
|
|||
(s-read (make-object string-snip% 0) f))
|
||||
|
||||
(def/public (s-read [string-snip% snip] [editor-stream-in% f])
|
||||
(let-boxes ([flags 0])
|
||||
(send f get flags)
|
||||
(let ([flags (send f get-exact)])
|
||||
(let ([pos (send f tell)])
|
||||
(let-boxes ([count 0])
|
||||
(send f get count)
|
||||
(let ([count (send f get-exact)])
|
||||
(send f jump-to pos)
|
||||
(let ([count (if (count . < . 0)
|
||||
10; this is a failure; we make up something
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -463,9 +463,9 @@ The functions are as follows.
|
|||
Called to obtain a progress event for the port, such as for
|
||||
@scheme[port-progress-evt]. This function can be @cpp{NULL} if the
|
||||
port does not support progress events. Use
|
||||
@cpp{progress_evt_via_get} to obtain a default implementation, in
|
||||
@cpp{scheme_progress_evt_via_get} to obtain a default implementation, in
|
||||
which case @var{peeked_read_fun} should be
|
||||
@cpp{peeked_read_via_get}, and @var{get_bytes_fun} and
|
||||
@cpp{scheme_peeked_read_via_get}, and @var{get_bytes_fun} and
|
||||
@var{peek_bytes_fun} should handle @var{unless} as described
|
||||
above.}
|
||||
|
||||
|
|
@ -477,9 +477,9 @@ The functions are as follows.
|
|||
|
||||
Called to commit previously peeked bytes, just like the sixth
|
||||
argument to @scheme[make-input-port]. Use
|
||||
@cpp{peeked_read_via_get} for the default implementation of
|
||||
@cpp{scheme_peeked_read_via_get} for the default implementation of
|
||||
commits when @var{progress_evt_fun} is
|
||||
@cpp{progress_evt_via_get}.}
|
||||
@cpp{scheme_progress_evt_via_get}.}
|
||||
|
||||
@subfunction[(int char_ready_fun
|
||||
[Scheme_Input_Port* port])]{
|
||||
|
|
|
|||
|
|
@ -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