diff --git a/collects/browser/browser.scrbl b/collects/browser/browser.scrbl index 5a9df3288a..025d9a9bc0 100644 --- a/collects/browser/browser.scrbl +++ b/collects/browser/browser.scrbl @@ -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 diff --git a/collects/mred/private/wxme/cycle.ss b/collects/mred/private/wxme/cycle.ss index 7bc9556321..ee30467e8d 100644 --- a/collects/mred/private/wxme/cycle.ss +++ b/collects/mred/private/wxme/cycle.ss @@ -25,3 +25,5 @@ (decl editor-put-file set-editor-put-file!) (decl popup-menu% set-popup-menu%!) + + diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 086ba4441a..8df9606949 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -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)]) diff --git a/collects/mred/private/wxme/snip.ss b/collects/mred/private/wxme/snip.ss index 510e148d6a..6b2da06896 100644 --- a/collects/mred/private/wxme/snip.ss +++ b/collects/mred/private/wxme/snip.ss @@ -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 diff --git a/collects/mred/private/wxme/stream.ss b/collects/mred/private/wxme/stream.ss index d5ed4bb417..85eb7d139a 100644 --- a/collects/mred/private/wxme/stream.ss +++ b/collects/mred/private/wxme/stream.ss @@ -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) diff --git a/collects/scribblings/inside/ports.scrbl b/collects/scribblings/inside/ports.scrbl index bb6ffc0f2d..4c8be45ac3 100644 --- a/collects/scribblings/inside/ports.scrbl +++ b/collects/scribblings/inside/ports.scrbl @@ -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])]{ diff --git a/collects/tests/mred/wxme.ss b/collects/tests/mred/wxme.ss index 3870cd3b20..869d90c448 100644 --- a/collects/tests/mred/wxme.ss +++ b/collects/tests/mred/wxme.ss @@ -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) ;; ----------------------------------------