suzanne.soy/racket
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
This commit is contained in:
Matthew Flatt 2009-04-15 22:27:43 +00:00
parent 0574391f0d
commit 119c69e1ad
7 changed files with 123 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/browser/browser.scrbl
View File

@ -8,6 +8,7 @@
browser/external browser/external
browser/tool browser/tool
scheme/base scheme/base
scheme/contract
scheme/class scheme/class
scheme/gui/base scheme/gui/base
net/url net/url
@ -26,8 +27,8 @@ The @schememodname[browser] library provides the following
procedures and classes for parsing and viewing HTML files. The procedures and classes for parsing and viewing HTML files. The
@schememodname[browser/htmltext] library provides a simplified @schememodname[browser/htmltext] library provides a simplified
interface for rendering to a subclass of the MrEd @scheme[text%] interface for rendering to a subclass of the MrEd @scheme[text%]
class. The [browser/external] library provides utilities for launching class. The @schememodname[browser/external] library provides utilities
an external browser (such as Firefox). for launching an external browser (such as Firefox).
@section[#:tag "browser"]{Browser} @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 The @(litchar "MZSCHEME") forms are disabled unless the web page is a
@(litchar "file:") url that points into the @scheme[doc] collection. @(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 Opens the given url
in a vanilla browser frame and returns in a vanilla browser frame and returns
the frame. The frame is an instance of the frame. The frame is an instance of

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%!)

21
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 len) (send f get-fixed-exact)
(set-box! len -1)) -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)])

6
collects/mred/private/wxme/snip.ss
View File

@ -315,11 +315,9 @@
(s-read (make-object string-snip% 0) f)) (s-read (make-object string-snip% 0) f))
(def/public (s-read [string-snip% snip] [editor-stream-in% f]) (def/public (s-read [string-snip% snip] [editor-stream-in% f])
(let-boxes ([flags 0]) (let ([flags (send f get-exact)])
(send f get flags)
(let ([pos (send f tell)]) (let ([pos (send f tell)])
(let-boxes ([count 0]) (let ([count (send f get-exact)])
(send f get count)
(send f jump-to pos) (send f jump-to pos)
(let ([count (if (count . < . 0) (let ([count (if (count . < . 0)
10; this is a failure; we make up something 10; this is a failure; we make up something

115
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])
(if (not (= 1 (send f read-bytes s))) (let ([b (send-generic f in-read-byte)])
(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)]
(if (and (= 1 (send f read-bytes s)) [b (send-generic f in-read-byte)])
(= (bytes-ref s 0) (char->integer #\|))) (if (and b
(= 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,8 +467,8 @@
(success) (success)
(loop))))])))) (loop))))]))))
(def/public (get-fixed [box? vb]) (def/public (get-fixed-exact)
(let ([v (if (check-boundary) (if (check-boundary)
0 0
(if (read-version . < . 8) (if (read-version . < . 8)
(let ([buf (make-bytes 4)]) (let ([buf (make-bytes 4)])
@ -459,8 +479,10 @@
(if (= read-version 1) (if (= read-version 1)
(system-big-endian?) (system-big-endian?)
#t))) #t)))
(get-exact)))]) (get-exact))))
(set-box! vb v)))
(def/public (get-fixed [box? vb])
(set-box! vb (get-fixed-exact)))
#| #|
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)

8
collects/scribblings/inside/ports.scrbl
View File

@ -463,9 +463,9 @@ The functions are as follows.
Called to obtain a progress event for the port, such as for Called to obtain a progress event for the port, such as for
@scheme[port-progress-evt]. This function can be @cpp{NULL} if the @scheme[port-progress-evt]. This function can be @cpp{NULL} if the
port does not support progress events. Use 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 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 @var{peek_bytes_fun} should handle @var{unless} as described
above.} above.}
@ -477,9 +477,9 @@ The functions are as follows.
Called to commit previously peeked bytes, just like the sixth Called to commit previously peeked bytes, just like the sixth
argument to @scheme[make-input-port]. Use 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 commits when @var{progress_evt_fun} is
@cpp{progress_evt_via_get}.} @cpp{scheme_progress_evt_via_get}.}
@subfunction[(int char_ready_fun @subfunction[(int char_ready_fun
[Scheme_Input_Port* port])]{ [Scheme_Input_Port* port])]{

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)
;; ---------------------------------------- ;; ----------------------------------------