diff --git a/collects/browser/private/btree.ss b/collects/browser/private/btree.ss index 76796cbf7b..65f9191ad7 100644 --- a/collects/browser/private/btree.ss +++ b/collects/browser/private/btree.ss @@ -1,220 +1,220 @@ #lang scheme/unit - (require "sig.ss") - +(require "sig.ss") + ;; Implements a red-black tree with relative indexing along right ;; splines. This allows the usual O(log(n)) operations, plus a ;; O(log(n)) shift operation. - + ;; (This is the same data structure as used for lines by MrEd's text% ;; class, but that one is implemented in C++.) - (import) - (export (rename relative-btree^ - (create-btree make-btree))) - - (define-struct btree (root)) - - (define-struct node (pos data parent left right color)) - - (define (adjust-offsets n new-child) - (when new-child - (set-node-pos! new-child (- (node-pos new-child) - (node-pos n))))) - - (define (deadjust-offsets n old-child) - (when old-child - (set-node-pos! old-child (+ (node-pos old-child) - (node-pos n))))) - - (define (rotate-left n btree) - (let ([old-right (node-right n)]) - (deadjust-offsets n old-right) +(import) +(export (rename relative-btree^ + (create-btree make-btree))) + +(define-struct btree (root) #:mutable) + +(define-struct node (pos data parent left right color) #:mutable) + +(define (adjust-offsets n new-child) + (when new-child + (set-node-pos! new-child (- (node-pos new-child) + (node-pos n))))) + +(define (deadjust-offsets n old-child) + (when old-child + (set-node-pos! old-child (+ (node-pos old-child) + (node-pos n))))) + +(define (rotate-left n btree) + (let ([old-right (node-right n)]) + (deadjust-offsets n old-right) + + (let ([r (node-left old-right)]) + (set-node-right! n r) + (when r + (set-node-parent! r n))) + + (let ([p (node-parent n)]) + (set-node-parent! old-right p) + (cond + [(not p) (set-btree-root! btree old-right)] + [(eq? n (node-left p)) (set-node-left! p old-right)] + [else (set-node-right! p old-right)])) + + (set-node-left! old-right n) + (set-node-parent! n old-right))) + +(define (rotate-right n btree) + (let ([old-left (node-left n)]) + (adjust-offsets old-left n) + + (let ([l (node-right old-left)]) + (set-node-left! n l) + (when l + (set-node-parent! l n))) + + (let ([p (node-parent n)]) + (set-node-parent! old-left p) + (cond + [(not p) (set-btree-root! btree old-left)] + [(eq? n (node-left p)) (set-node-left! p old-left)] + [else (set-node-right! p old-left)])) + + (set-node-right! old-left n) + (set-node-parent! n old-left))) + + +(define (insert before? n btree pos data) + (let ([new (make-node pos data #f #f #f 'black)]) + (if (not (btree-root btree)) + (set-btree-root! btree new) + + (begin - (let ([r (node-left old-right)]) - (set-node-right! n r) - (when r - (set-node-parent! r n))) + (set-node-color! new 'red) - (let ([p (node-parent n)]) - (set-node-parent! old-right p) - (cond - [(not p) (set-btree-root! btree old-right)] - [(eq? n (node-left p)) (set-node-left! p old-right)] - [else (set-node-right! p old-right)])) - - (set-node-left! old-right n) - (set-node-parent! n old-right))) - - (define (rotate-right n btree) - (let ([old-left (node-left n)]) - (adjust-offsets old-left n) - - (let ([l (node-right old-left)]) - (set-node-left! n l) - (when l - (set-node-parent! l n))) - - (let ([p (node-parent n)]) - (set-node-parent! old-left p) - (cond - [(not p) (set-btree-root! btree old-left)] - [(eq? n (node-left p)) (set-node-left! p old-left)] - [else (set-node-right! p old-left)])) - - (set-node-right! old-left n) - (set-node-parent! n old-left))) - - - (define (insert before? n btree pos data) - (let ([new (make-node pos data #f #f #f 'black)]) - (if (not (btree-root btree)) - (set-btree-root! btree new) + ; Insert into tree + (if before? - (begin - - (set-node-color! new 'red) - - ; Insert into tree - (if before? - - (if (not (node-left n)) + (if (not (node-left n)) + (begin + (set-node-left! n new) + (set-node-parent! new n)) + + (let loop ([node (node-left n)]) + (if (node-right node) + (loop (node-right node)) (begin - (set-node-left! n new) - (set-node-parent! new n)) - - (let loop ([node (node-left n)]) - (if (node-right node) - (loop (node-right node)) - (begin - (set-node-right! node new) - (set-node-parent! new node))))) - - (if (not (node-right n)) + (set-node-right! node new) + (set-node-parent! new node))))) + + (if (not (node-right n)) + (begin + (set-node-right! n new) + (set-node-parent! new n)) + + (let loop ([node (node-right n)]) + (if (node-left node) + (loop (node-left node)) (begin - (set-node-right! n new) - (set-node-parent! new n)) - - (let loop ([node (node-right n)]) - (if (node-left node) - (loop (node-left node)) - (begin - (set-node-left! node new) - (set-node-parent! new node)))))) - - ; Make value in new node relative to right-hand parents - (let loop ([node new]) - (let ([p (node-parent node)]) - (when p - (when (eq? node (node-right p)) - (adjust-offsets p new)) - (loop p)))) - - ; Balance tree - (let loop ([node new]) - (let ([p (node-parent node)]) - (when (and (not (eq? node (btree-root btree))) - (eq? 'red (node-color p))) - (let* ([recolor-k - (lambda (y) - (set-node-color! p 'black) - (set-node-color! y 'black) - (let ([pp (node-parent p)]) - (set-node-color! pp 'red) - (loop pp)))] - [rotate-k - (lambda (rotate node) - (let ([p (node-parent node)]) - (set-node-color! p 'black) - (let ([pp (node-parent p)]) - (set-node-color! pp 'red) - (rotate pp btree) - (loop pp))))] - [k - (lambda (node-y long-rotate always-rotate) - (let ([y (node-y (node-parent p))]) - (if (and y (eq? 'red (node-color y))) - (recolor-k y) - (let ([k (lambda (node) - (rotate-k always-rotate node))]) - (if (eq? node (node-y p)) - (begin - (long-rotate p btree) - (k p)) - (k node))))))]) - (if (eq? p (node-left (node-parent p))) - (k node-right rotate-left rotate-right) - (k node-left rotate-right rotate-left)))))) - - (set-node-color! (btree-root btree) 'black))))) - - (define (find-following-node btree pos) - (let ([root (btree-root btree)]) - (let loop ([n root] - [so-far root] - [so-far-pos (and root (node-pos root))] - [v 0]) - (if (not n) - (values so-far so-far-pos) - (let ([npos (+ (node-pos n) v)]) - (cond - [(<= pos npos) - (loop (node-left n) n npos v)] - [(or (not so-far-pos) - (> npos so-far-pos)) - (loop (node-right n) n npos npos)] - [else - (loop (node-right n) so-far so-far-pos npos)])))))) - - (define (create-btree) - (make-btree #f)) - - (define (btree-get btree pos) - (let-values ([(n npos) (find-following-node btree pos)]) - (and n - (= npos pos) - (node-data n)))) - - (define (btree-put! btree pos data) - (let-values ([(n npos) (find-following-node btree pos)]) - (if (and n (= npos pos)) - (set-node-data! n data) - (insert (and n (< pos npos)) - n btree pos data)))) - - (define (btree-shift! btree start delta) - (let loop ([n (btree-root btree)] - [v 0]) - (when n - (let ([npos (node-pos n)]) - (cond - [(< start (+ v npos)) - (set-node-pos! n (+ npos delta)) - (loop (node-left n) v)] - [else - (loop (node-right n) (+ v npos))]))))) - - (define (btree-for-each btree f) - (when (btree-root btree) - (let loop ([n (btree-root btree)] - [v 0]) - (when (node-left n) - (loop (node-left n) v)) - (f (+ v (node-pos n)) (node-data n)) - (when (node-right n) - (loop (node-right n) - (+ v (node-pos n))))))) - - (define (btree-map btree f) - (reverse - (let loop ([n (btree-root btree)] - [v 0] - [a null]) - (if (not n) - a - (let* ([pre (loop (node-left n) v a)] - [here (cons (f (+ v (node-pos n)) - (node-data n)) - pre)]) - (loop (node-right n) - (+ v (node-pos n)) - here)))))) + (set-node-left! node new) + (set-node-parent! new node)))))) + + ; Make value in new node relative to right-hand parents + (let loop ([node new]) + (let ([p (node-parent node)]) + (when p + (when (eq? node (node-right p)) + (adjust-offsets p new)) + (loop p)))) + + ; Balance tree + (let loop ([node new]) + (let ([p (node-parent node)]) + (when (and (not (eq? node (btree-root btree))) + (eq? 'red (node-color p))) + (let* ([recolor-k + (lambda (y) + (set-node-color! p 'black) + (set-node-color! y 'black) + (let ([pp (node-parent p)]) + (set-node-color! pp 'red) + (loop pp)))] + [rotate-k + (lambda (rotate node) + (let ([p (node-parent node)]) + (set-node-color! p 'black) + (let ([pp (node-parent p)]) + (set-node-color! pp 'red) + (rotate pp btree) + (loop pp))))] + [k + (lambda (node-y long-rotate always-rotate) + (let ([y (node-y (node-parent p))]) + (if (and y (eq? 'red (node-color y))) + (recolor-k y) + (let ([k (lambda (node) + (rotate-k always-rotate node))]) + (if (eq? node (node-y p)) + (begin + (long-rotate p btree) + (k p)) + (k node))))))]) + (if (eq? p (node-left (node-parent p))) + (k node-right rotate-left rotate-right) + (k node-left rotate-right rotate-left)))))) + + (set-node-color! (btree-root btree) 'black))))) + +(define (find-following-node btree pos) + (let ([root (btree-root btree)]) + (let loop ([n root] + [so-far root] + [so-far-pos (and root (node-pos root))] + [v 0]) + (if (not n) + (values so-far so-far-pos) + (let ([npos (+ (node-pos n) v)]) + (cond + [(<= pos npos) + (loop (node-left n) n npos v)] + [(or (not so-far-pos) + (> npos so-far-pos)) + (loop (node-right n) n npos npos)] + [else + (loop (node-right n) so-far so-far-pos npos)])))))) + +(define (create-btree) + (make-btree #f)) + +(define (btree-get btree pos) + (let-values ([(n npos) (find-following-node btree pos)]) + (and n + (= npos pos) + (node-data n)))) + +(define (btree-put! btree pos data) + (let-values ([(n npos) (find-following-node btree pos)]) + (if (and n (= npos pos)) + (set-node-data! n data) + (insert (and n (< pos npos)) + n btree pos data)))) + +(define (btree-shift! btree start delta) + (let loop ([n (btree-root btree)] + [v 0]) + (when n + (let ([npos (node-pos n)]) + (cond + [(< start (+ v npos)) + (set-node-pos! n (+ npos delta)) + (loop (node-left n) v)] + [else + (loop (node-right n) (+ v npos))]))))) + +(define (btree-for-each btree f) + (when (btree-root btree) + (let loop ([n (btree-root btree)] + [v 0]) + (when (node-left n) + (loop (node-left n) v)) + (f (+ v (node-pos n)) (node-data n)) + (when (node-right n) + (loop (node-right n) + (+ v (node-pos n))))))) + +(define (btree-map btree f) + (reverse + (let loop ([n (btree-root btree)] + [v 0] + [a null]) + (if (not n) + a + (let* ([pre (loop (node-left n) v a)] + [here (cons (f (+ v (node-pos n)) + (node-data n)) + pre)]) + (loop (node-right n) + (+ v (node-pos n)) + here)))))) diff --git a/collects/browser/private/html.ss b/collects/browser/private/html.ss index 3a80c75200..32de862cf8 100644 --- a/collects/browser/private/html.ss +++ b/collects/browser/private/html.ss @@ -1,1262 +1,1259 @@ #lang scheme/unit - (require "sig.ss" - (lib "mred-sig.ss" "mred") - (lib "file.ss") - (lib "etc.ss") - (lib "list.ss") - (lib "string.ss") - (lib "port.ss") - (lib "url-sig.ss" "net") - (only (lib "html.ss" "html") - read-html-as-xml read-html-comments use-html-spec) - (all-except (lib "xml.ss" "xml") read-comments) - (lib "class.ss") - "bullet.ss" - "option-snip.ss" - "entity-names.ss") - - - (import mred^ url^) - (export html^) - (init-depend mred^) - - ;; CACHE - (define NUM-CACHED 10) - (define cached (make-vector 10 'no-image)) - (define cached-name (make-vector 10 #f)) ; string or #f - (define cached-use (make-vector 10 0)) - - (define html-status-handler - (make-parameter - void - (lambda (f) - (unless (and (procedure? f) - (procedure-arity-includes? f 1)) - (raise-type-error 'html-status-handler - "procedure of arity 1" - f)) - f))) - - (define (status . args) - ((html-status-handler) (apply format args))) - - (define status-stack (make-parameter null)) - - ;; load-status : boolean string (union #f url) -> void - (define (load-status push? what url) - (let ([s (format "Loading ~a ~a..." - what - (if url - (trim 150 (url->string url)) - "unknown url"))]) - (status-stack (cons s (if push? (status-stack) null))) - (status "~a" s))) - - (define (pop-status) - (status-stack (cdr (status-stack))) - (status "~a" (car (status-stack)))) - (define (trim len s) - (if ((string-length s) . <= . len) - s - (string-append (substring s 0 (- len 4)) " ..."))) +(require "sig.ss" + (lib "mred-sig.ss" "mred") + scheme/file + (lib "port.ss") + (lib "url-sig.ss" "net") + (only-in (lib "html.ss" "html") + read-html-as-xml read-html-comments use-html-spec) + (except-in (lib "xml.ss" "xml") read-comments) + (lib "class.ss") + "bullet.ss" + "option-snip.ss" + "entity-names.ss") + + +(import mred^ url^) +(export html^) +(init-depend mred^) + +;; CACHE +(define NUM-CACHED 10) +(define cached (make-vector 10 'no-image)) +(define cached-name (make-vector 10 #f)) ; string or #f +(define cached-use (make-vector 10 0)) + +(define html-status-handler + (make-parameter + void + (lambda (f) + (unless (and (procedure? f) + (procedure-arity-includes? f 1)) + (raise-type-error 'html-status-handler + "procedure of arity 1" + f)) + f))) + +(define (status . args) + ((html-status-handler) (apply format args))) + +(define status-stack (make-parameter null)) + +;; load-status : boolean string (union #f url) -> void +(define (load-status push? what url) + (let ([s (format "Loading ~a ~a..." + what + (if url + (trim 150 (url->string url)) + "unknown url"))]) + (status-stack (cons s (if push? (status-stack) null))) + (status "~a" s))) + +(define (pop-status) + (status-stack (cdr (status-stack))) + (status "~a" (car (status-stack)))) +(define (trim len s) + (if ((string-length s) . <= . len) + s + (string-append (substring s 0 (- len 4)) " ..."))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; Imap maps - ;; +;; +;; Imap maps +;; - (define-struct image-map-rect (href left top right bottom)) - - (define finger-cursor (make-object cursor% 'arrow)) - - (define image-map-snip% - (class image-snip% - - (init-field html-text) - - (field [key "#key"]) - (define/public (set-key k) (set! key k)) - (define/public (get-key) key) - - (field [rects null]) - - (define/public (set-rects rs) (set! rects rs)) - - (inherit get-admin) - - (define/private (find-rect x y) - (let loop ([rects rects]) - (cond - [(null? rects) #f] - [else - (let ([rect (car rects)]) - (if (and (<= (image-map-rect-left rect) x (image-map-rect-right rect)) - (<= (image-map-rect-top rect) y (image-map-rect-bottom rect))) - rect - (loop (cdr rects))))]))) - - ;; add-area : string (listof number) string -> void - ;; currently only supports rect shapes - (define/public (add-area shape coords href) - (when (and (equal? shape "rect") - (= 4 (length coords))) - (let ([x1 (car coords)] - [y1 (cadr coords)] - [x2 (caddr coords)] - [y2 (cadddr coords)]) - (set! rects (cons (make-image-map-rect - href - (min x1 x2) - (min y1 y2) - (max x1 x2) - (max y1 y2)) - rects))))) - - (define/override (on-event dc x y editor-x editor-y evt) - (when (send evt button-up?) - (let* ([snipx (- (send evt get-x) x)] - [snipy (- (send evt get-y) y)] - [rect (find-rect snipx snipy)]) - (when rect - (send html-text post-url (image-map-rect-href rect))))) - (super on-event dc x y editor-x editor-y evt)) - - (define/override (adjust-cursor dc x y editor-x editor-y evt) - (let ([snipx (- (send evt get-x) x)] - [snipy (- (send evt get-y) y)]) - (if (find-rect snipx snipy) - finger-cursor - #f))) +(define-struct image-map-rect (href left top right bottom)) - ;; warning: buggy. This doesn't actually copy the bitmap - ;; over because there's no get-bitmap method for image-snip% - ;; at the time of this writing. - (define/override (copy) - (let ([cp (new image-map-snip% (html-text html-text))]) - (send cp set-key key) - (send cp set-rects rects))) - - (super-make-object) - - (inherit set-flags get-flags) - (set-flags (cons 'handles-events (get-flags))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; Hardwired Scheme colorization; should come from a .css file - ;; +(define finger-cursor (make-object cursor% 'arrow)) - (define (make-scheme-color-delta col) - (let ([d (make-object style-delta%)]) - (send d set-delta-foreground col) - d)) - - (define scheme-code-delta (make-scheme-color-delta "brown")) - (define scheme-code-delta/keyword - (let ([d (make-scheme-color-delta (make-object color% #x99 0 0))]) - (send d set-weight-on 'bold) - d)) - (define scheme-code-delta/variable (make-scheme-color-delta "navy")) - (define scheme-code-delta/global (make-scheme-color-delta "purple")) - (define scheme-code-delta/selfeval (make-scheme-color-delta "forest green")) - (define scheme-code-delta/comment (make-scheme-color-delta "cornflower blue")) - (define navigation-delta (let ([d (make-scheme-color-delta "red")]) - (send d set-style-on 'italic) - d)) - - (define current-style-class (make-parameter null)) - - (define (lookup-class-delta class) - (let ([class-path (cons class (current-style-class))]) - (cond - [(sub-path? class-path '("scheme")) scheme-code-delta] - [(sub-path? class-path '("keyword" "scheme")) scheme-code-delta/keyword] - [(sub-path? class-path '("variable" "scheme")) scheme-code-delta/variable] - [(sub-path? class-path '("global" "scheme")) scheme-code-delta/global] - [(or (sub-path? class-path '("selfeval" "scheme")) - (sub-path? class-path '("schemeresponse"))) scheme-code-delta/selfeval] - [(sub-path? class-path '("comment" "scheme")) scheme-code-delta/comment] - [(sub-path? class-path '("navigation")) navigation-delta] - [else #f]))) - - (define (sub-path? a b) - (cond - [(null? b) #t] - [(null? a) #f] - [else (and (equal? (car a) (car b)) - (sub-path? (cdr a) (cdr b)))])) - - (define (with-style-class class thunk) - (if class - (parameterize ([current-style-class (cons class (current-style-class))]) - (thunk)) - (thunk))) - - (define (lookup-span-class-delta class) (lookup-class-delta class)) - - (define re:hexcolor - (regexp "^#([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])$")) - - (define color-string->color - (lambda (str) - (let ([m (regexp-match re:hexcolor str)]) - (if m - (make-object color% - (string->number (cadr m) 16) - (string->number (caddr m) 16) - (string->number (cadddr m) 16)) - (send the-color-database find-color str))))) - - (define html-eval-ok (make-parameter #t)) - (define html-img-ok (make-parameter #t)) - - (define (get-bitmap-from-url url) - (if (html-img-ok) - (let ([tmp-filename (make-temporary-file "mredimg~a")]) - (load-status #t "image" url) - (call-with-output-file* tmp-filename - (lambda (op) - (with-handlers ([exn:fail? - (lambda (x) - (printf "exn.9 ~s\n" (and (exn? x) - (exn-message x))) - (void))]) - (call/input-url - url - get-pure-port - (lambda (ip) - (copy-port ip op))))) - 'truncate) - (pop-status) - (let ([bitmap (make-object bitmap% tmp-filename)]) - (with-handlers ([exn:fail? - (lambda (x) - (message-box "Warning" - (format "Could not delete file ~s~n~n~a" - tmp-filename - (if (exn? x) - (exn-message x) - x))))]) - (delete-file tmp-filename)) - (if (send bitmap ok?) - bitmap - #f))) - #f)) - - ;; cache-bitmap : string -> (is-a?/c bitmap%) - (define (cache-bitmap url) - (let ([url-string (url->string url)]) - (let loop ([n 0]) - (cond - [(= n NUM-CACHED) - ;; Look for item to uncache - (vector-set! cached-use 0 (max 0 (sub1 (vector-ref cached-use 0)))) - (let ([m (let loop ([n 1][m (vector-ref cached-use 0)]) - (if (= n NUM-CACHED) - m - (begin - (vector-set! cached-use n (max 0 (sub1 (vector-ref cached-use n)))) - (loop (add1 n) (min m (vector-ref cached-use n))))))]) - (let loop ([n 0]) - (if (= (vector-ref cached-use n) m) - (let ([bitmap (get-bitmap-from-url url)]) - (cond - [bitmap - (vector-set! cached n bitmap) - (vector-set! cached-name n url-string) - (vector-set! cached-use n 5) - bitmap] - [else #f])) - (loop (add1 n)))))] - [(equal? url-string (vector-ref cached-name n)) - (vector-set! cached-use n (min 10 (add1 (vector-ref cached-use n)))) - (vector-ref cached n)] - [else - (loop (add1 n))])))) - - (define (update-image-maps image-map-snips image-maps) - (for-each - (lambda (image-map-snip) - (let ([image-map-key (send image-map-snip get-key)]) - (let loop ([image-maps image-maps]) - (cond - [(null? image-maps) (void)] - [else - (let* ([image-map (car image-maps)] - [name (get-field image-map 'name)]) - (if (and name - (equal? (format "#~a" name) - (send image-map-snip get-key))) - (find/add-areas image-map-snip image-map) - (loop (cdr image-maps))))])))) - image-map-snips)) - - (define (find/add-areas image-map-snip image-map) - (let loop ([sexp image-map]) - (cond - [(and (pair? sexp) - (eq? (car sexp) 'area) - (pair? (cdr sexp))) - (add-area image-map-snip (cadr sexp)) - (loop (cddr sexp))] - [(pair? sexp) - (loop (car sexp)) - (loop (cdr sexp))] - [else (void)]))) - - ;; add-area : snip (listof (list sym string))[assoc] -> void - ;; the second arg type is actually `any', but if it - ;; matches the above, it is interprted propoerly; - ;; otherwise silently nothing happens. - (define (add-area image-map-snip sexp) - (let ([shape #f] - [coords #f] - [href #f]) - (let loop ([sexp sexp]) - (cond - [(pair? sexp) - (let ([fst (car sexp)]) - (when (and (pair? fst) - (symbol? (car fst)) - (pair? (cdr fst)) - (string? (cadr fst))) - (case (car fst) - [(shape) (set! shape (cadr fst))] - [(coords) (set! coords (cadr fst))] - [(href) (set! href (cadr fst))] - [else (void)])) - (loop (cdr sexp)))] - [else (void)])) - (when (and shape coords href) - (let ([p-coords (parse-coords coords)]) - (when p-coords - (send image-map-snip add-area shape p-coords href)))))) - - ;; parse-coords : string -> (listof number) - ;; separates out a bunch of comma separated numbers in a string - ;; into a list of scheme numbers - (define (parse-coords str) - (let loop ([str str]) - (cond - [(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*,(.*)$" str) - => - (lambda (m) - (let ([num (cadr m)] - [rst (caddr m)]) - (cons (string->number num) - (loop rst))))] - [(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*" str) - => - (lambda (m) - (list (string->number (cadr m))))] - [else null]))) - - (define (make-get-field str) - (let ([s (apply - string-append - (map - (lambda (c) - (format "[~a~a]" - (char-upcase c) - (char-downcase c))) - (string->list str)))] - [spc (string #\space #\tab #\newline #\return #\vtab)]) - (let ([re:plain (regexp (format "(^|[~a])~a[~a]*=[~a]*([^~a]*)" spc s spc spc spc))] - [re:quote (regexp (format "(^|[~a])~a[~a]*=[~a]*\"([^\"]*)\"" spc s spc spc))]) - (lambda (args) - (let ([m (or (regexp-match re:quote args) - (regexp-match re:plain args))]) - (and m (caddr m))))))) - - (define (get-field e name) - (let ([a (assq name (cadr e))]) - (and a (cadr a)))) - - (define get-mzscheme-arg - (let ([get-mz (make-get-field "mzscheme")]) - (lambda (str) - (let ([v (get-mz str)]) - (and v (filter-mzscheme v)))))) - - (define filter-mzscheme - (lambda (v) - (regexp-replace* "[|]" v "\""))) - - (define face-list #f) - - (define default-font (make-object font% 12 'default)) - - (define re:quot (regexp "[&][qQ][uU][oO][tT][;]")) - (define re:amp (regexp "[&][aA][mM][pP][;]")) - - (define re:empty (regexp (format "^[ ~c]*$" (integer->char 160)))) - - (define-struct form (action target method parts active-select)) - (define (protect-chars s) - (apply string-append - (map (lambda (c) - (if (or (char-alphabetic? c) - (char-numeric? c)) - (string c) - (format "%~a" - (let ([s (format "0~x" (or (char->integer c) 65))]) - (substring s (- (string-length s) 2) (string-length s)))))) - (string->list s)))) - - (define re:true (regexp-quote "true" #f)) - (define (true? s) (regexp-match re:true s)) - - (define verbatim-tags '(listing xmp plaintext)) - (define preformatted-tags '(pre)) - (define exact-whitespace-tags (append verbatim-tags - preformatted-tags)) - (define comment-tags '(script)) - (define atomic-tags '(p br hr li dd dt img html meta link input)) - (define enum-tags '(ul dl ol menu)) - - (define space-eating-tags '(title p div center br h1 h2 h3 h4 - li dt dd - ul ol dl menu - samp kbd pre blockquote - table tr td)) - - (define whitespace-string "[ \t\n\r\v\f]+") - (define re:whitespace (regexp whitespace-string)) - (define re:starting-whitespace (regexp (format "^~a" whitespace-string))) - (define re:ending-whitespace (regexp (format "~a$" whitespace-string))) - (define re:leading-newline (regexp "^(\r|\n|(\r\n))")) - - (define (remove-leading-newline c) - (cond - [(string? c) - (let ([s (regexp-match-positions re:leading-newline c)]) - (cond - [(and s (= (cdar s) (length s))) - ;; It's all newline: - (values "" #t)] - [s (values (substring c (cdar s) (string-length c)) #t)] - [else (values c #t)]))] - [(pair? c) - (let loop ([b (cddr c)][accum null]) - (if (null? b) - (values (list* (car c) (cadr c) (reverse accum)) #f) - (let-values ([(d done?) (remove-leading-newline (car b))]) - (if done? - (values (list* (car c) (cadr c) (append (reverse accum) - (list d) - (cdr b))) - #t) - (loop (cdr b) (cons d accum))))))] - [else (values c #f)])) - - (define (fixup-whitespace c leading-ok?) +(define image-map-snip% + (class image-snip% + + (init-field html-text) + + (field [key "#key"]) + (define/public (set-key k) (set! key k)) + (define/public (get-key) key) + + (field [rects null]) + + (define/public (set-rects rs) (set! rects rs)) + + (inherit get-admin) + + (define/private (find-rect x y) + (let loop ([rects rects]) (cond - [(string? c) - (let ([s (regexp-match-positions re:starting-whitespace c)] - [e (regexp-match-positions re:ending-whitespace c)]) - (if (and s e - (= (caar s) (caar e))) - ;; It's all whitespace: - (if leading-ok? - (values " " #f) - (values "" #f)) - ;; Normal case: + [(null? rects) #f] + [else + (let ([rect (car rects)]) + (if (and (<= (image-map-rect-left rect) x (image-map-rect-right rect)) + (<= (image-map-rect-top rect) y (image-map-rect-bottom rect))) + rect + (loop (cdr rects))))]))) + + ;; add-area : string (listof number) string -> void + ;; currently only supports rect shapes + (define/public (add-area shape coords href) + (when (and (equal? shape "rect") + (= 4 (length coords))) + (let ([x1 (car coords)] + [y1 (cadr coords)] + [x2 (caddr coords)] + [y2 (cadddr coords)]) + (set! rects (cons (make-image-map-rect + href + (min x1 x2) + (min y1 y2) + (max x1 x2) + (max y1 y2)) + rects))))) + + (define/override (on-event dc x y editor-x editor-y evt) + (when (send evt button-up?) + (let* ([snipx (- (send evt get-x) x)] + [snipy (- (send evt get-y) y)] + [rect (find-rect snipx snipy)]) + (when rect + (send html-text post-url (image-map-rect-href rect))))) + (super on-event dc x y editor-x editor-y evt)) + + (define/override (adjust-cursor dc x y editor-x editor-y evt) + (let ([snipx (- (send evt get-x) x)] + [snipy (- (send evt get-y) y)]) + (if (find-rect snipx snipy) + finger-cursor + #f))) + + ;; warning: buggy. This doesn't actually copy the bitmap + ;; over because there's no get-bitmap method for image-snip% + ;; at the time of this writing. + (define/override (copy) + (let ([cp (new image-map-snip% (html-text html-text))]) + (send cp set-key key) + (send cp set-rects rects))) + + (super-make-object) + + (inherit set-flags get-flags) + (set-flags (cons 'handles-events (get-flags))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Hardwired Scheme colorization; should come from a .css file +;; + +(define (make-scheme-color-delta col) + (let ([d (make-object style-delta%)]) + (send d set-delta-foreground col) + d)) + +(define scheme-code-delta (make-scheme-color-delta "brown")) +(define scheme-code-delta/keyword + (let ([d (make-scheme-color-delta (make-object color% #x99 0 0))]) + (send d set-weight-on 'bold) + d)) +(define scheme-code-delta/variable (make-scheme-color-delta "navy")) +(define scheme-code-delta/global (make-scheme-color-delta "purple")) +(define scheme-code-delta/selfeval (make-scheme-color-delta "forest green")) +(define scheme-code-delta/comment (make-scheme-color-delta "cornflower blue")) +(define navigation-delta (let ([d (make-scheme-color-delta "red")]) + (send d set-style-on 'italic) + d)) + +(define current-style-class (make-parameter null)) + +(define (lookup-class-delta class) + (let ([class-path (cons class (current-style-class))]) + (cond + [(sub-path? class-path '("scheme")) scheme-code-delta] + [(sub-path? class-path '("keyword" "scheme")) scheme-code-delta/keyword] + [(sub-path? class-path '("variable" "scheme")) scheme-code-delta/variable] + [(sub-path? class-path '("global" "scheme")) scheme-code-delta/global] + [(or (sub-path? class-path '("selfeval" "scheme")) + (sub-path? class-path '("schemeresponse"))) scheme-code-delta/selfeval] + [(sub-path? class-path '("comment" "scheme")) scheme-code-delta/comment] + [(sub-path? class-path '("navigation")) navigation-delta] + [else #f]))) + +(define (sub-path? a b) + (cond + [(null? b) #t] + [(null? a) #f] + [else (and (equal? (car a) (car b)) + (sub-path? (cdr a) (cdr b)))])) + +(define (with-style-class class thunk) + (if class + (parameterize ([current-style-class (cons class (current-style-class))]) + (thunk)) + (thunk))) + +(define (lookup-span-class-delta class) (lookup-class-delta class)) + +(define re:hexcolor + (regexp "^#([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])$")) + +(define color-string->color + (lambda (str) + (let ([m (regexp-match re:hexcolor str)]) + (if m + (make-object color% + (string->number (cadr m) 16) + (string->number (caddr m) 16) + (string->number (cadddr m) 16)) + (send the-color-database find-color str))))) + +(define html-eval-ok (make-parameter #t)) +(define html-img-ok (make-parameter #t)) + +(define (get-bitmap-from-url url) + (if (html-img-ok) + (let ([tmp-filename (make-temporary-file "mredimg~a")]) + (load-status #t "image" url) + (call-with-output-file* tmp-filename + (lambda (op) + (with-handlers ([exn:fail? + (lambda (x) + (printf "exn.9 ~s\n" (and (exn? x) + (exn-message x))) + (void))]) + (call/input-url + url + get-pure-port + (lambda (ip) + (copy-port ip op))))) + 'truncate) + (pop-status) + (let ([bitmap (make-object bitmap% tmp-filename)]) + (with-handlers ([exn:fail? + (lambda (x) + (message-box "Warning" + (format "Could not delete file ~s~n~n~a" + tmp-filename + (if (exn? x) + (exn-message x) + x))))]) + (delete-file tmp-filename)) + (if (send bitmap ok?) + bitmap + #f))) + #f)) + +;; cache-bitmap : string -> (is-a?/c bitmap%) +(define (cache-bitmap url) + (let ([url-string (url->string url)]) + (let loop ([n 0]) + (cond + [(= n NUM-CACHED) + ;; Look for item to uncache + (vector-set! cached-use 0 (max 0 (sub1 (vector-ref cached-use 0)))) + (let ([m (let loop ([n 1][m (vector-ref cached-use 0)]) + (if (= n NUM-CACHED) + m + (begin + (vector-set! cached-use n (max 0 (sub1 (vector-ref cached-use n)))) + (loop (add1 n) (min m (vector-ref cached-use n))))))]) + (let loop ([n 0]) + (if (= (vector-ref cached-use n) m) + (let ([bitmap (get-bitmap-from-url url)]) + (cond + [bitmap + (vector-set! cached n bitmap) + (vector-set! cached-name n url-string) + (vector-set! cached-use n 5) + bitmap] + [else #f])) + (loop (add1 n)))))] + [(equal? url-string (vector-ref cached-name n)) + (vector-set! cached-use n (min 10 (add1 (vector-ref cached-use n)))) + (vector-ref cached n)] + [else + (loop (add1 n))])))) + +(define (update-image-maps image-map-snips image-maps) + (for-each + (lambda (image-map-snip) + (let ([image-map-key (send image-map-snip get-key)]) + (let loop ([image-maps image-maps]) + (cond + [(null? image-maps) (void)] + [else + (let* ([image-map (car image-maps)] + [name (get-field image-map 'name)]) + (if (and name + (equal? (format "#~a" name) + (send image-map-snip get-key))) + (find/add-areas image-map-snip image-map) + (loop (cdr image-maps))))])))) + image-map-snips)) + +(define (find/add-areas image-map-snip image-map) + (let loop ([sexp image-map]) + (cond + [(and (pair? sexp) + (eq? (car sexp) 'area) + (pair? (cdr sexp))) + (add-area image-map-snip (cadr sexp)) + (loop (cddr sexp))] + [(pair? sexp) + (loop (car sexp)) + (loop (cdr sexp))] + [else (void)]))) + +;; add-area : snip (listof (list sym string))[assoc] -> void +;; the second arg type is actually `any', but if it +;; matches the above, it is interprted propoerly; +;; otherwise silently nothing happens. +(define (add-area image-map-snip sexp) + (let ([shape #f] + [coords #f] + [href #f]) + (let loop ([sexp sexp]) + (cond + [(pair? sexp) + (let ([fst (car sexp)]) + (when (and (pair? fst) + (symbol? (car fst)) + (pair? (cdr fst)) + (string? (cadr fst))) + (case (car fst) + [(shape) (set! shape (cadr fst))] + [(coords) (set! coords (cadr fst))] + [(href) (set! href (cadr fst))] + [else (void)])) + (loop (cdr sexp)))] + [else (void)])) + (when (and shape coords href) + (let ([p-coords (parse-coords coords)]) + (when p-coords + (send image-map-snip add-area shape p-coords href)))))) + +;; parse-coords : string -> (listof number) +;; separates out a bunch of comma separated numbers in a string +;; into a list of scheme numbers +(define (parse-coords str) + (let loop ([str str]) + (cond + [(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*,(.*)$" str) + => + (lambda (m) + (let ([num (cadr m)] + [rst (caddr m)]) + (cons (string->number num) + (loop rst))))] + [(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*" str) + => + (lambda (m) + (list (string->number (cadr m))))] + [else null]))) + +(define (make-get-field str) + (let ([s (apply + string-append + (map + (lambda (c) + (format "[~a~a]" + (char-upcase c) + (char-downcase c))) + (string->list str)))] + [spc (string #\space #\tab #\newline #\return #\vtab)]) + (let ([re:plain (regexp (format "(^|[~a])~a[~a]*=[~a]*([^~a]*)" spc s spc spc spc))] + [re:quote (regexp (format "(^|[~a])~a[~a]*=[~a]*\"([^\"]*)\"" spc s spc spc))]) + (lambda (args) + (let ([m (or (regexp-match re:quote args) + (regexp-match re:plain args))]) + (and m (caddr m))))))) + +(define (get-field e name) + (let ([a (assq name (cadr e))]) + (and a (cadr a)))) + +(define get-mzscheme-arg + (let ([get-mz (make-get-field "mzscheme")]) + (lambda (str) + (let ([v (get-mz str)]) + (and v (filter-mzscheme v)))))) + +(define filter-mzscheme + (lambda (v) + (regexp-replace* "[|]" v "\""))) + +(define face-list #f) + +(define default-font (make-object font% 12 'default)) + +(define re:quot (regexp "[&][qQ][uU][oO][tT][;]")) +(define re:amp (regexp "[&][aA][mM][pP][;]")) + +(define re:empty (regexp (format "^[ ~c]*$" (integer->char 160)))) + +(define-struct form (action target method [parts #:mutable] [active-select #:mutable])) +(define (protect-chars s) + (apply string-append + (map (lambda (c) + (if (or (char-alphabetic? c) + (char-numeric? c)) + (string c) + (format "%~a" + (let ([s (format "0~x" (or (char->integer c) 65))]) + (substring s (- (string-length s) 2) (string-length s)))))) + (string->list s)))) + +(define re:true (regexp-quote "true" #f)) +(define (true? s) (regexp-match re:true s)) + +(define verbatim-tags '(listing xmp plaintext)) +(define preformatted-tags '(pre)) +(define exact-whitespace-tags (append verbatim-tags + preformatted-tags)) +(define comment-tags '(script)) +(define atomic-tags '(p br hr li dd dt img html meta link input)) +(define enum-tags '(ul dl ol menu)) + +(define space-eating-tags '(title p div center br h1 h2 h3 h4 + li dt dd + ul ol dl menu + samp kbd pre blockquote + table tr td)) + +(define whitespace-string "[ \t\n\r\v\f]+") +(define re:whitespace (regexp whitespace-string)) +(define re:starting-whitespace (regexp (format "^~a" whitespace-string))) +(define re:ending-whitespace (regexp (format "~a$" whitespace-string))) +(define re:leading-newline (regexp "^(\r|\n|(\r\n))")) + +(define (remove-leading-newline c) + (cond + [(string? c) + (let ([s (regexp-match-positions re:leading-newline c)]) + (cond + [(and s (= (cdar s) (length s))) + ;; It's all newline: + (values "" #t)] + [s (values (substring c (cdar s) (string-length c)) #t)] + [else (values c #t)]))] + [(pair? c) + (let loop ([b (cddr c)][accum null]) + (if (null? b) + (values (list* (car c) (cadr c) (reverse accum)) #f) + (let-values ([(d done?) (remove-leading-newline (car b))]) + (if done? + (values (list* (car c) (cadr c) (append (reverse accum) + (list d) + (cdr b))) + #t) + (loop (cdr b) (cons d accum))))))] + [else (values c #f)])) + +(define (fixup-whitespace c leading-ok?) + (cond + [(string? c) + (let ([s (regexp-match-positions re:starting-whitespace c)] + [e (regexp-match-positions re:ending-whitespace c)]) + (if (and s e + (= (caar s) (caar e))) + ;; It's all whitespace: + (if leading-ok? + (values " " #f) + (values "" #f)) + ;; Normal case: + (values + (string-append + (if (and s leading-ok?) " " "") + (regexp-replace* re:whitespace + (substring c + (if s + (cdar s) + 0) + (if e + (caar e) + (string-length c))) + " ") + (if e " " "")) + (not e))))] + [(symbol? c) (values c #t)] + [(number? c) (values c #t)] + [(comment? c) + (let ([code (get-mzscheme-arg (comment-text c))]) + (if code + (let ([s (with-handlers ([exn:fail? + (lambda (exn) + (format + "Error during <!-- MZSCHEME=... -->: ~a" + (if (exn? exn) + (exn-message exn) + (format "~s" exn))))]) + (if (html-eval-ok) + (eval (read (open-input-string code))) + (error "disabled")))]) + (if (string? s) + (let ([content (read-html (open-input-string s))]) + (fixup-whitespace content leading-ok?)) + (values "" leading-ok?))) + (values "" leading-ok?)))] + [(pi? c) (values "" leading-ok?)] ;; processing instruction + [else (let ([tag (car c)]) + (if (memq tag exact-whitespace-tags) + (let-values ([(s done?) (remove-leading-newline c)]) + (values s #f)) + (let-values ([(body leading-ok?) + (let loop ([l (cddr c)][leading-ok? + (and leading-ok? + (not (memq tag space-eating-tags)))]) + (if (null? l) + (values null leading-ok?) + (let*-values ([(f l-ok?) + (fixup-whitespace (car l) leading-ok?)] + [(r l-ok?) + (loop (cdr l) l-ok?)]) + (values (cons f r) l-ok?))))]) (values - (string-append - (if (and s leading-ok?) " " "") - (regexp-replace* re:whitespace - (substring c - (if s - (cdar s) - 0) - (if e - (caar e) - (string-length c))) - " ") - (if e " " "")) - (not e))))] - [(symbol? c) (values c #t)] - [(number? c) (values c #t)] - [(comment? c) - (let ([code (get-mzscheme-arg (comment-text c))]) - (if code - (let ([s (with-handlers ([exn:fail? - (lambda (exn) - (format - "Error during <!-- MZSCHEME=... -->: ~a" - (if (exn? exn) - (exn-message exn) - (format "~s" exn))))]) - (if (html-eval-ok) - (eval (read (open-input-string code))) - (error "disabled")))]) - (if (string? s) - (let ([content (read-html (open-input-string s))]) - (fixup-whitespace content leading-ok?)) - (values "" leading-ok?))) - (values "" leading-ok?)))] - [(pi? c) (values "" leading-ok?)] ;; processing instruction - [else (let ([tag (car c)]) - (if (memq tag exact-whitespace-tags) - (let-values ([(s done?) (remove-leading-newline c)]) - (values s #f)) - (let-values ([(body leading-ok?) - (let loop ([l (cddr c)][leading-ok? - (and leading-ok? - (not (memq tag space-eating-tags)))]) - (if (null? l) - (values null leading-ok?) - (let*-values ([(f l-ok?) - (fixup-whitespace (car l) leading-ok?)] - [(r l-ok?) - (loop (cdr l) l-ok?)]) - (values (cons f r) l-ok?))))]) - (values - (list* - tag - (cadr c) ; attributes - body) - (and leading-ok? - (not (memq tag space-eating-tags)))))))])) + (list* + tag + (cadr c) ; attributes + body) + (and leading-ok? + (not (memq tag space-eating-tags)))))))])) - (define (read-html a-port) - (let* ([xml (parameterize ([read-html-comments #t] - [use-html-spec #f]) - (read-html-as-xml a-port))] - [xexpr `(html () ,@(map xml->xexpr xml))]) - xexpr)) - - (define (parse-html a-port) - (let ([raw (read-html a-port)]) - (let-values ([(v ?) (fixup-whitespace raw #f)]) - v))) +(define (read-html a-port) + (let* ([xml (parameterize ([read-html-comments #t] + [use-html-spec #f]) + (read-html-as-xml a-port))] + [xexpr `(html () ,@(map xml->xexpr xml))]) + xexpr)) - (define html-convert - (lambda (a-port a-text) - (let ([content (parse-html a-port)]) - (with-method ([a-text-insert (a-text insert)] - [current-pos (a-text last-position)] - [delete (a-text delete)] - [get-character (a-text get-character)] - [change-style (a-text change-style)]) - (letrec ([image-map-snips null] - [image-maps null] - - [html-basic-style - (let ([sl (send a-text get-style-list)]) - (or (send sl find-named-style "Html Standard") - (send sl find-named-style "Standard") - (send sl find-named-style "Basic")))] - - ;; inserts - [insert - (λ (what) - (let ([pos-before (current-pos)]) - (a-text-insert what pos-before) - (let ([pos-after (current-pos)]) - (change-style html-basic-style pos-before pos-after))))] - - [insert-newlines - (lambda (num forced-lines para-base) - (let ([num (max num forced-lines)]) - (unless (zero? num) - (let loop ([pos (current-pos)][num num]) - (unless (or (zero? num) (<= pos para-base)) - (let ([c (get-character (sub1 pos))]) - (if (eq? c #\newline) - (loop (sub1 pos) (sub1 num)) - (insert (make-string num #\newline)))))))))] - - [backover-newlines - (lambda (pos base) - (if (= pos base) - base - (let ([c (get-character (sub1 pos))]) - (if (eq? c #\newline) - (backover-newlines (sub1 pos) base) - pos))))] - - [whitespaces (string #\space #\tab #\newline #\return)] - - [delta:fixed (make-object style-delta% 'change-family 'modern)] - [delta:default-face (make-object style-delta% 'change-family 'default)] - [delta:bold (make-object style-delta% 'change-bold)] - [delta:underline (make-object style-delta% 'change-underline #t)] - [delta:italic (make-object style-delta% 'change-italic)] - [delta:h1 (let ([d (make-object style-delta% 'change-bold)]) - (send d set-size-mult 2.0) - d)] - [delta:h2 (let ([d (make-object style-delta% 'change-bold)]) - (send d set-size-mult 1.5) - d)] - [delta:h3 (let ([d (make-object style-delta% 'change-bold)]) - (send d set-size-mult 1.2) - d)] - [delta:h4 (make-object style-delta% 'change-bold)] - [delta:subscript (let ([d (make-object style-delta%)]) - (send d set-alignment-on 'bottom) - (send d set-size-mult 0.8) - d)] - [delta:superscript (let ([d (make-object style-delta%)]) - (send d set-alignment-on 'top) - (send d set-size-mult 0.8) - d)] - [delta:small (let ([d (make-object style-delta%)]) - (send d set-size-mult 0.75) - d)] - - [delta:center (make-object style-delta% 'change-alignment 'center)] - [delta:symbol (make-object style-delta% 'change-family 'symbol)] - - [html-error - (lambda args - (when #f ; treat them all as ignored warnings - (apply error 'html args)))] - - [re:transparent #rx"[Tt][Rr][Aa][Nn][Ss][Pp][Aa][Rr][Ee][Nn][Tt]"] - - [parse-image-source - (lambda (s) - (let ([src (get-field s 'src)] - [base-url (send a-text get-url)]) - (and src - (with-handlers ([exn:fail? (lambda (x) #f)]) - (if base-url - (combine-url/relative base-url src) - (string->url src))))))] - - [unescape - (lambda (s) - (apply string-append - (map (lambda (x) - (if (pcdata? x) - (pcdata-string x) - "")) - (read-html-as-xml - (open-input-string s)))))] - [parse-href - (let ([href-error +(define (parse-html a-port) + (let ([raw (read-html a-port)]) + (let-values ([(v ?) (fixup-whitespace raw #f)]) + v))) + +(define html-convert + (lambda (a-port a-text) + (let ([content (parse-html a-port)]) + (with-method ([a-text-insert (a-text insert)] + [current-pos (a-text last-position)] + [delete (a-text delete)] + [get-character (a-text get-character)] + [change-style (a-text change-style)]) + (letrec ([image-map-snips null] + [image-maps null] + + [html-basic-style + (let ([sl (send a-text get-style-list)]) + (or (send sl find-named-style "Html Standard") + (send sl find-named-style "Standard") + (send sl find-named-style "Basic")))] + + ;; inserts + [insert + (λ (what) + (let ([pos-before (current-pos)]) + (a-text-insert what pos-before) + (let ([pos-after (current-pos)]) + (change-style html-basic-style pos-before pos-after))))] + + [insert-newlines + (lambda (num forced-lines para-base) + (let ([num (max num forced-lines)]) + (unless (zero? num) + (let loop ([pos (current-pos)][num num]) + (unless (or (zero? num) (<= pos para-base)) + (let ([c (get-character (sub1 pos))]) + (if (eq? c #\newline) + (loop (sub1 pos) (sub1 num)) + (insert (make-string num #\newline)))))))))] + + [backover-newlines + (lambda (pos base) + (if (= pos base) + base + (let ([c (get-character (sub1 pos))]) + (if (eq? c #\newline) + (backover-newlines (sub1 pos) base) + pos))))] + + [whitespaces (string #\space #\tab #\newline #\return)] + + [delta:fixed (make-object style-delta% 'change-family 'modern)] + [delta:default-face (make-object style-delta% 'change-family 'default)] + [delta:bold (make-object style-delta% 'change-bold)] + [delta:underline (make-object style-delta% 'change-underline #t)] + [delta:italic (make-object style-delta% 'change-italic)] + [delta:h1 (let ([d (make-object style-delta% 'change-bold)]) + (send d set-size-mult 2.0) + d)] + [delta:h2 (let ([d (make-object style-delta% 'change-bold)]) + (send d set-size-mult 1.5) + d)] + [delta:h3 (let ([d (make-object style-delta% 'change-bold)]) + (send d set-size-mult 1.2) + d)] + [delta:h4 (make-object style-delta% 'change-bold)] + [delta:subscript (let ([d (make-object style-delta%)]) + (send d set-alignment-on 'bottom) + (send d set-size-mult 0.8) + d)] + [delta:superscript (let ([d (make-object style-delta%)]) + (send d set-alignment-on 'top) + (send d set-size-mult 0.8) + d)] + [delta:small (let ([d (make-object style-delta%)]) + (send d set-size-mult 0.75) + d)] + + [delta:center (make-object style-delta% 'change-alignment 'center)] + [delta:symbol (make-object style-delta% 'change-family 'symbol)] + + [html-error + (lambda args + (when #f ; treat them all as ignored warnings + (apply error 'html args)))] + + [re:transparent #rx"[Tt][Rr][Aa][Nn][Ss][Pp][Aa][Rr][Ee][Nn][Tt]"] + + [parse-image-source + (lambda (s) + (let ([src (get-field s 'src)] + [base-url (send a-text get-url)]) + (and src + (with-handlers ([exn:fail? (lambda (x) #f)]) + (if base-url + (combine-url/relative base-url src) + (string->url src))))))] + + [unescape + (lambda (s) + (apply string-append + (map (lambda (x) + (if (pcdata? x) + (pcdata-string x) + "")) + (read-html-as-xml + (open-input-string s)))))] + [parse-href + (let ([href-error + (lambda (s) + (html-error "bad reference in ~s" s))]) (lambda (s) - (html-error "bad reference in ~s" s))]) - (lambda (s) - (let* ([url-string - (cond - [(get-field s 'href) - => (lambda (str) - (if (string=? str "") - (begin (href-error s) - #f) - (unescape str)))] - [else #f])] - [label (get-field s 'name)] - [scheme (let ([v (get-field s 'mzscheme)]) - (and v (filter-mzscheme v)))]) - (values url-string label scheme))))] - - [parse-font - (let ([face-regexp (regexp "([^,]*), *(.*)")]) - (lambda (args) - (let ([size-string (get-field args 'size)] - [face-string (get-field args 'face)] - [color-string (get-field args 'color)] - [bg-color-string (get-field args 'bgcolor)]) - (let ([size - (and size-string - (let* ([n (string->number size-string)]) - (and n - (integer? n) - (<= -127 n 127) - (cond - [(char=? #\+ (string-ref size-string 0)) - (make-object style-delta% 'change-bigger n)] - [(negative? n) - (make-object style-delta% 'change-smaller (- n))] - [else - (cond - [(n . < . 2) - (make-object style-delta% 'change-smaller (- 2 n))] - [(n . > . 2) - (make-object style-delta% 'change-bigger (- n 2))] - [else #f])]))))] - [face (and face-string - (or - (and (string=? face-string "monospace") - (make-object style-delta% 'change-family 'modern)) - (let ([f (let loop ([f face-string]) - (let ([m (regexp-match face-regexp f)] - [try-face (lambda (s) - (unless face-list - (set! face-list (get-face-list))) - (ormap - (lambda (s-norm) - (and (string-ci=? s s-norm) - s-norm)) - face-list))]) - (if m - (or (try-face (cadr m)) - (loop (caddr m))) - (try-face f))))]) - (and f + (let* ([url-string + (cond + [(get-field s 'href) + => (lambda (str) + (if (string=? str "") + (begin (href-error s) + #f) + (unescape str)))] + [else #f])] + [label (get-field s 'name)] + [scheme (let ([v (get-field s 'mzscheme)]) + (and v (filter-mzscheme v)))]) + (values url-string label scheme))))] + + [parse-font + (let ([face-regexp (regexp "([^,]*), *(.*)")]) + (lambda (args) + (let ([size-string (get-field args 'size)] + [face-string (get-field args 'face)] + [color-string (get-field args 'color)] + [bg-color-string (get-field args 'bgcolor)]) + (let ([size + (and size-string + (let* ([n (string->number size-string)]) + (and n + (integer? n) + (<= -127 n 127) + (cond + [(char=? #\+ (string-ref size-string 0)) + (make-object style-delta% 'change-bigger n)] + [(negative? n) + (make-object style-delta% 'change-smaller (- n))] + [else + (cond + [(n . < . 2) + (make-object style-delta% 'change-smaller (- 2 n))] + [(n . > . 2) + (make-object style-delta% 'change-bigger (- n 2))] + [else #f])]))))] + [face (and face-string + (or + (and (string=? face-string "monospace") + (make-object style-delta% 'change-family 'modern)) + (let ([f (let loop ([f face-string]) + (let ([m (regexp-match face-regexp f)] + [try-face (lambda (s) + (unless face-list + (set! face-list (get-face-list))) + (ormap + (lambda (s-norm) + (and (string-ci=? s s-norm) + s-norm)) + face-list))]) + (if m + (or (try-face (cadr m)) + (loop (caddr m))) + (try-face f))))]) + (and f + (let ([d (make-object style-delta%)]) + (send d set-delta-face f))))))] + [color (let ([clr (and color-string (color-string->color color-string))]) + (and clr (let ([d (make-object style-delta%)]) - (send d set-delta-face f))))))] - [color (let ([clr (and color-string (color-string->color color-string))]) - (and clr - (let ([d (make-object style-delta%)]) - (send d set-delta-foreground clr))))] - [bg-color (let ([bg-clr (and bg-color-string - (color-string->color bg-color-string))]) - (and bg-clr - (let ([d (make-object style-delta%)]) - (send d set-delta-background bg-clr))))]) - (let loop ([delta #f][l (list size face color bg-color)]) - (cond - [(null? l) delta] - [(not (car l)) (loop delta (cdr l))] - [else (if delta - (loop (begin - (send delta collapse (car l)) - delta) - (cdr l)) - (loop (car l) (cdr l)))]))))))] - - [make-unsupported - (lambda (tag args) - (let ([name (get-field args 'name)] - [type (get-field args 'type)]) - (if (and (eq? tag 'input) type (string=? type "hidden")) - "" ; hidden input - (format "[~a~a NOT SUPPORTED]" - (if name - (format "~a " name) - "") - (case tag - [(select) "POPUP MENU"] - [(textarea) "TEXT AREA"] - [(input) (if type - (case (string->symbol type) - [(text) "TEXT FIELD"] - [else "BUTTON"]) - "BUTTON")])))))] - - [heading (lambda (delta forced-lines rest para-base) - (insert-newlines 2 forced-lines para-base) - (let-values ([(start-pos) (current-pos)] - [(r rfl) (rest)] - [(end-pos) (current-pos)]) - (insert-newlines 2 rfl para-base) - (values - (lambda () - (change-style delta start-pos end-pos) - (r)) - rfl)))] - - [styler (opt-lambda (delta rest [drop-empty? #f]) - (let*-values ([(start-pos) (current-pos)] - [(r rfl) (rest)] - [(end-pos) (current-pos)]) - (if (and drop-empty? - (regexp-match re:empty (send a-text get-text start-pos end-pos))) - (begin - (delete start-pos end-pos) - (values void rfl)) - (values - (lambda () - (change-style delta start-pos end-pos) - (r)) - rfl))))] - - [maybe-bg-color (lambda (e rest drop-empty?) - (let* ([c (get-field e 'bgcolor)] - [color (and c (color-string->color c))]) - (cond - [color - (styler (let ([d (make-object style-delta%)]) - (send d set-delta-background color) - d) - rest - drop-empty?)] - [drop-empty? - (let*-values ([(start-pos) (current-pos)] - [(r rfl) (rest)] - [(end-pos) (current-pos)]) - (values (if (regexp-match re:empty (send a-text get-text start-pos end-pos)) - void - r) - rfl))] - [else - (rest)])))] - - [para-aligner (lambda (alignment delta rest) - (let*-values ([(start-pos) (current-pos)] - [(r rfl) (rest)] - [(end-pos) (current-pos)]) + (send d set-delta-foreground clr))))] + [bg-color (let ([bg-clr (and bg-color-string + (color-string->color bg-color-string))]) + (and bg-clr + (let ([d (make-object style-delta%)]) + (send d set-delta-background bg-clr))))]) + (let loop ([delta #f][l (list size face color bg-color)]) + (cond + [(null? l) delta] + [(not (car l)) (loop delta (cdr l))] + [else (if delta + (loop (begin + (send delta collapse (car l)) + delta) + (cdr l)) + (loop (car l) (cdr l)))]))))))] + + [make-unsupported + (lambda (tag args) + (let ([name (get-field args 'name)] + [type (get-field args 'type)]) + (if (and (eq? tag 'input) type (string=? type "hidden")) + "" ; hidden input + (format "[~a~a NOT SUPPORTED]" + (if name + (format "~a " name) + "") + (case tag + [(select) "POPUP MENU"] + [(textarea) "TEXT AREA"] + [(input) (if type + (case (string->symbol type) + [(text) "TEXT FIELD"] + [else "BUTTON"]) + "BUTTON")])))))] + + [heading (lambda (delta forced-lines rest para-base) + (insert-newlines 2 forced-lines para-base) + (let-values ([(start-pos) (current-pos)] + [(r rfl) (rest)] + [(end-pos) (current-pos)]) + (insert-newlines 2 rfl para-base) (values (lambda () - (let ([last-para (send a-text position-paragraph - (backover-newlines end-pos start-pos))]) - (let loop ([para (send a-text position-paragraph start-pos)]) - (if (eq? alignment 'left-outdent) - (begin - (send a-text set-paragraph-alignment para 'left) - (send a-text set-paragraph-margins para 0 (* 2 (get-bullet-width)) 0)) - (send a-text set-paragraph-alignment para alignment)) - (when delta - (change-style delta start-pos end-pos)) - (unless (= para last-para) - (loop (add1 para))))) + (change-style delta start-pos end-pos) (r)) rfl)))] - - ;; translate-number : number -> void - [translate-number - (lambda (e) - (cond - [(and (not (= e #xFFFF)) - (not (= e #xFFFE)) - (not (<= #xD800 e #xDFFF)) - (send default-font screen-glyph-exists? (integer->char e))) - (insert (integer->char e)) - void] - [(<= 913 e 969) - (let ([lp (current-pos)]) - (insert (integer->char (+ (- e 913) (char->integer #\A)))) - (lambda () - (change-style delta:symbol lp (+ lp 1))))] - ;; poor ascii approximations. probably these - ;; (and other) characters exist somewhere, - ;; but I don't know where. - [(= e 160) (insert " ") void] - [(= e 338) (insert "OE") void] - [(= e 339) (insert "oe") void] - [(= e 732) (insert "~") void] - [(= e 710) (insert "^") void] - [(= e 8242) (insert "'") void] - [(= e 8243) (insert "''") void] - [(= e 8260) (insert "/") void] - [(= e 8722) (insert "-") void] - [(= e 8727) (insert "*") void] - [(= e 8764) (insert "~") void] - [(= e 8804) (insert "<") void] - [(= e 8805) (insert ">") void] - [(= e 8211) (insert "--") void] - [(= e 8212) (insert "---") void] - - [else (insert (format "&#~a;" e)) - void]))] - - ;; ======================================== - ;; This is the main formatting function. - ;; It consumes: - ;; e : xexpr - the HTML content - ;; para-base : num - a marker for a paragraph start (e.g., - ;; the bullet for
  • ), though the actual - ;; paragraph start may be later - ;; enum-depth : num - current depth of enumerations - ;; The result is a function of no arguments that finalizes - ;; the region for `e', which normally means applying font changes. - ;; (The changes have to be applied outside-in, so that local - ;; specifications override enclosing ones.) - ;; Translate must not modify any existing text, and the - ;; result function must not move any items. - [translate - (lambda (e para-base enum-depth forced-lines form) - (cond - [(string? e) - (let ([lp (current-pos)]) - (insert e) - ;; we change the style here directly - ;; since we want this style to only appear - ;; if the style is overridden by the context - (change-style delta:default-face - lp - (+ lp (string-length e))) - (values void - 0))] - [(symbol? e) - (let ([a (entity-name->integer e)]) - (if a - (values (translate-number a) 0) - (begin - (insert (format "&~a;" e)) - (values void 0))))] - [(number? e) - (values (translate-number e) 0)] - [(or (comment? e) (pi? e)) (values void forced-lines)] - [else (let* ([tag (car e)] - [rest/base/depth/form/fl - (lambda (para-base enum-depth form forced-lines) - (let* ([p (foldl (lambda (x p) - (let-values ([(f fl) (translate x para-base enum-depth (car p) form)]) - (cons fl (cons f (cdr p))))) - (cons forced-lines null) - (cddr e))] - [l (reverse (cdr p))]) - (values (lambda () - (map (lambda (f) (f)) l)) - (car p))))] - [rest/base/depth - (lambda (para-base enum-depth) - (rest/base/depth/form/fl para-base enum-depth form forced-lines))] - [rest/form (lambda (form) (rest/base/depth/form/fl para-base enum-depth form forced-lines))] - [rest/form (lambda (form) (rest/base/depth/form/fl para-base enum-depth form forced-lines))] - [rest (lambda () (rest/base/depth/form/fl para-base enum-depth form forced-lines))] - [rest/fl (lambda (fl) (rest/base/depth/form/fl para-base enum-depth form fl))]) - (case tag - [(title) - (let ([pos (current-pos)]) - ;; Render content - (rest) - (send a-text set-title (send a-text get-text pos (current-pos))) - (delete pos (current-pos))) - (values void forced-lines)] - [(a) - (let-values ([(url-string label scheme) (parse-href e)]) - (let* ([style (get-field e 'style)] - [pos (current-pos)]) - (let-values ([(r rfl) (rest)]) - (let ([end-pos (current-pos)]) - (cond - [url-string - (send a-text add-link pos end-pos (regexp-replace* re:amp url-string "\\&")) - ;; might have a label, too: - (when label - (send a-text add-tag label pos)) - (values - (lambda () - (when (or (not style) - (not (regexp-match re:transparent style))) - (send a-text make-link-style pos end-pos)) - (r)) - rfl)] - [label - (send a-text add-tag label pos) - (values r rfl)] - [scheme - (send a-text add-scheme-callback pos end-pos scheme) - (values - (lambda () - (when (or (not style) - (not (regexp-match re:transparent style))) - (send a-text make-link-style pos end-pos)) - (r)) - rfl)] - [else (values r rfl)])))))] - [(style) (values void forced-lines)] - [(h1) (heading delta:h1 forced-lines rest para-base)] - [(h2) (heading delta:h2 forced-lines rest para-base)] - [(h3) (heading delta:h3 forced-lines rest para-base)] - [(h4) (heading delta:h4 forced-lines rest para-base)] - [(b strong) (styler delta:bold rest)] - [(i em var dfn cite) (styler delta:italic rest)] - [(u) (styler delta:underline rest)] - [(sup) (styler delta:superscript rest)] - [(sub) (styler delta:subscript rest)] - [(small) (styler delta:small rest)] - [(font) - (let ([delta (parse-font e)]) - (if delta - (styler delta rest) - (rest)))] - [(li dd dt) - (insert-newlines 1 forced-lines para-base) - (let ([pos (current-pos)] - [bullet? (eq? tag 'li)]) - (when bullet? - (let ([before (current-pos)]) - (insert (make-object bullet-snip% (sub1 enum-depth))) - (change-style (send (send a-text get-style-list) find-named-style "Standard") - before - (+ before 1)))) - (let*-values ([(r rfl) (rest/base/depth (add1 pos) enum-depth)] - [(end-pos) (current-pos)]) - (values - (lambda () - (let ([end-para (send a-text position-paragraph - (backover-newlines end-pos pos))] - [left-margin (* 2 (get-bullet-width) enum-depth)]) - (let loop ([para (send a-text position-paragraph pos)] - [first? #t]) - (send a-text set-paragraph-margins - para - (if first? - (max 0 (- left-margin - (if bullet? - (get-bullet-width) - 0))) - left-margin) - left-margin - 0) - (unless (= para end-para) - (loop (add1 para) #f)))) - (r)) - rfl)))] - [(ul menu ol dl) - (insert-newlines (if (zero? enum-depth) 2 1) forced-lines para-base) - (let-values ([(r rfl) - (rest/base/depth para-base (add1 enum-depth))]) - (insert-newlines (if (zero? enum-depth) 2 1) rfl para-base) - (values r rfl))] - [(p) - (insert-newlines 2 forced-lines para-base) - (let-values ([(r rfl) (rest)]) - (insert-newlines 2 rfl para-base) - (values r rfl))] - [(blockquote) - (insert-newlines 2 forced-lines para-base) - (let*-values ([(pos) (current-pos)] - [(r rfl) (rest/base/depth para-base (add1 enum-depth))] - [(end-pos) (current-pos)]) - (begin0 - (values - (lambda () - (let ([end-para (send a-text position-paragraph - (backover-newlines end-pos pos))] - [left-margin (* 2 (get-bullet-width) (add1 enum-depth))]) - (let loop ([para (send a-text position-paragraph pos)]) - (send a-text set-paragraph-margins - para - left-margin - left-margin - left-margin) - (unless (= para end-para) - (loop (add1 para))))) - (r)) - rfl) - (insert-newlines 2 rfl para-base)))] - [(center) - (insert-newlines 2 forced-lines para-base) - (let-values ([(r rfl) - (para-aligner 'center #f rest)]) - (insert-newlines 2 rfl para-base) - (values r rfl))] - [(div) - (insert-newlines 1 forced-lines para-base) - (let* ([align (get-field e 'align)] - [class (get-field e 'class)] - [delta (and class (lookup-class-delta class))]) - (with-style-class - class - (lambda () - (let-values ([(r rfl) - (cond - [(and (string? align) (string-ci=? align "center")) - (para-aligner 'center delta rest)] - [(and (string? align) (string-ci=? align "left")) - (para-aligner 'left delta rest)] - [(and (string? align) (string-ci=? align "left-outdent")) - (para-aligner 'left-outdent delta rest)] - [(or (and (string? align) (string-ci=? align "right")) - (and (string? class) (string-ci=? class "navigation"))) - (para-aligner 'right delta rest)] - [delta - (styler delta rest)] - [else (rest)])]) - (insert-newlines 1 rfl para-base) - (values r rfl)))))] - [(br) - (insert-newlines 1 (+ 1 forced-lines) para-base) - (rest/fl (+ forced-lines 1))] - [(table) - (insert-newlines 1 forced-lines para-base) - (let-values ([(r rfl) - (maybe-bg-color e rest #t)]) - (insert-newlines 1 rfl para-base) - (values r (max 1 rfl)))] - [(tr) - (insert-newlines 1 forced-lines para-base) - (let-values ([(r rfl) - (maybe-bg-color e rest #t)]) - (insert-newlines 1 rfl para-base) - (values r rfl))] - [(td) - (maybe-bg-color e rest #t)] - [(map) - (set! image-maps (cons e image-maps)) - (rest)] - [(img) - (let* ([url (parse-image-source e)] - [alt (get-field e 'alt)] - [bitmap (and url (cache-bitmap url))] - [usemap (get-field e 'usemap)]) - (cond - [(and bitmap usemap) - (let ([pos (current-pos)] - [image-map-snip (make-object image-map-snip% a-text)]) - (send image-map-snip set-bitmap bitmap) - (send image-map-snip set-key usemap) - (insert image-map-snip) - (set! image-map-snips (cons image-map-snip image-map-snips)) - (change-style delta:center pos (add1 pos)))] - [bitmap - (let ([pos (current-pos)]) - (insert (make-object image-snip% bitmap)) - (change-style delta:center pos (add1 pos)))] - [alt - (insert alt)] - [else - (let ([pos (current-pos)]) - (insert (new image-snip%)) - (change-style delta:center pos (add1 pos)))]) - (rest))] - [(form) - (rest/form (make-form (get-field e 'action) (get-field e 'target) (get-field e 'method) null #f))] - [(input select textarea) - (let ([unsupported (make-unsupported tag e)] - [pos (current-pos)] - [type (let ([t (get-field e 'type)]) - (and t (string->symbol t)))] - [send-form (lambda (add-self?) - (let ([post-string - (apply - string-append - (map (lambda (v) - (if (car v) - (format "~a=~a&" - (car v) - (protect-chars (or ((cdr v)) - "?"))) - "")) - (form-parts form)))]) - (send a-text post-url - (form-action form) - (string->bytes/utf-8 - (if add-self? - ;; Add this button - (format "~a~a=~a" - post-string - (get-field e 'name) - (protect-chars (get-field e 'value))) - ;; remove trailing & - (substring post-string - 0 - (max 0 (sub1 (string-length post-string)))))))))]) - (let-values ([(name cb get-val) - (cond - [(eq? tag 'select) - (let ([select (make-object option-snip%)]) - (set-form-active-select! form select) - (insert select) - (values (get-field e 'name) - #f - (lambda () - (send select get-value))))] - [(or (and (eq? tag 'input) - (or (not type) (eq? type 'text))) - (eq? tag 'textarea)) - (let* ([text (make-object text%)] - [snip (make-object editor-snip% text)] - [size (get-field e 'size)] - [val (get-field e 'value)]) - (let ([km (send text get-keymap)]) - ((current-text-keymap-initializer) km) - (unless (eq? tag 'textarea) - (send km add-function "send-form" - (lambda (t e) - (send-form #f))) - (send km map-function "enter" "send-form"))) - (let ([width (* 10 (or (and size (string->number size)) - 25))]) - (send text set-min-width width) - (send text set-max-width width)) - (when val - (send text insert val)) - (insert snip) - (values - (get-field e 'name) - #f - (lambda () (send text get-text))))] - [(and (eq? tag 'input) - (eq? type 'submit)) - (insert (get-field e 'value)) - (values - #f ; because we leave out this button when it's not pushed - (lambda () - (send-form #t)) - #f)] - [(and (eq? tag 'input) - (eq? type 'checkbox)) - (let ([cb (make-object checkbox-snip% (true? (or (get-field e 'value) "false")))]) - (insert cb) - (values - (get-field e 'name) - #f - (lambda () (if (send cb get-value) - "true" - "false"))))] - [(and (eq? tag 'input) - (eq? type 'hidden)) - (values - (get-field e 'name) - #f - (lambda () (regexp-replace* re:quot (get-field e 'value) "\"")))] - [else - (insert unsupported) - (values #f #f #f)])]) - (set-form-parts! form - (cons (cons name - (or get-val - (lambda () - (get-field e 'value)))) - (form-parts form))) - (let-values ([(r rfl) (rest)] - [(end-pos) (current-pos)]) - (set-form-active-select! form #f) - (values - (lambda () - (cond - [cb - (send a-text make-link-style pos end-pos) - (send a-text add-thunk-callback pos end-pos cb)] - [else - (change-style delta:default-face pos end-pos)]) - (r)) - rfl))))] - [(option) - (let-values ([(pos) (current-pos)] + [styler (lambda (delta rest [drop-empty? #f]) + (let*-values ([(start-pos) (current-pos)] [(r rfl) (rest)] - [(val) (get-field e 'value)] - [(selected?) (true? (or (get-field e 'selected) - "false"))] [(end-pos) (current-pos)]) - (let ([str (send a-text get-text pos end-pos)] - [select (form-active-select form)]) - (delete pos end-pos) - (when select - (send select add-option str (or val str)) - (when selected? - (send select set-value val))) - (values r rfl)))] - [(tt code samp kbd pre) - (when (memq tag '(pre)) - (insert-newlines 2 forced-lines para-base)) - (let-values ([(r rfl) - (let* ([class (get-field e 'class)] - [delta (and class (lookup-class-delta class))]) - (with-style-class - class - (lambda () - (styler (if delta - (let ([d (make-object style-delta% 'change-nothing)]) - (send d copy delta) - (send d collapse delta:fixed) - d) - delta:fixed) - rest))))]) - (when (memq tag '(pre)) - (insert-newlines 2 rfl para-base)) - (values r rfl))] - [(span) - (let* ([class (get-field e 'class)] - [delta (and class (lookup-class-delta class))]) - (if delta - (styler delta rest) - (rest)))] - [else (rest)]))]))]) - (load-status #f "page" (send a-text get-url)) - (let-values ([(f fl) (translate content 0 0 0 (make-form #f #f #f null #f))]) - (f)) - (send a-text add-tag "top" 0) - (update-image-maps image-map-snips image-maps) - (send a-text set-position 0)))))) + (if (and drop-empty? + (regexp-match re:empty (send a-text get-text start-pos end-pos))) + (begin + (delete start-pos end-pos) + (values void rfl)) + (values + (lambda () + (change-style delta start-pos end-pos) + (r)) + rfl))))] + + [maybe-bg-color (lambda (e rest drop-empty?) + (let* ([c (get-field e 'bgcolor)] + [color (and c (color-string->color c))]) + (cond + [color + (styler (let ([d (make-object style-delta%)]) + (send d set-delta-background color) + d) + rest + drop-empty?)] + [drop-empty? + (let*-values ([(start-pos) (current-pos)] + [(r rfl) (rest)] + [(end-pos) (current-pos)]) + (values (if (regexp-match re:empty (send a-text get-text start-pos end-pos)) + void + r) + rfl))] + [else + (rest)])))] + + [para-aligner (lambda (alignment delta rest) + (let*-values ([(start-pos) (current-pos)] + [(r rfl) (rest)] + [(end-pos) (current-pos)]) + (values + (lambda () + (let ([last-para (send a-text position-paragraph + (backover-newlines end-pos start-pos))]) + (let loop ([para (send a-text position-paragraph start-pos)]) + (if (eq? alignment 'left-outdent) + (begin + (send a-text set-paragraph-alignment para 'left) + (send a-text set-paragraph-margins para 0 (* 2 (get-bullet-width)) 0)) + (send a-text set-paragraph-alignment para alignment)) + (when delta + (change-style delta start-pos end-pos)) + (unless (= para last-para) + (loop (add1 para))))) + (r)) + rfl)))] + + ;; translate-number : number -> void + [translate-number + (lambda (e) + (cond + [(and (not (= e #xFFFF)) + (not (= e #xFFFE)) + (not (<= #xD800 e #xDFFF)) + (send default-font screen-glyph-exists? (integer->char e))) + (insert (integer->char e)) + void] + [(<= 913 e 969) + (let ([lp (current-pos)]) + (insert (integer->char (+ (- e 913) (char->integer #\A)))) + (lambda () + (change-style delta:symbol lp (+ lp 1))))] + + ;; poor ascii approximations. probably these + ;; (and other) characters exist somewhere, + ;; but I don't know where. + [(= e 160) (insert " ") void] + [(= e 338) (insert "OE") void] + [(= e 339) (insert "oe") void] + [(= e 732) (insert "~") void] + [(= e 710) (insert "^") void] + [(= e 8242) (insert "'") void] + [(= e 8243) (insert "''") void] + [(= e 8260) (insert "/") void] + [(= e 8722) (insert "-") void] + [(= e 8727) (insert "*") void] + [(= e 8764) (insert "~") void] + [(= e 8804) (insert "<") void] + [(= e 8805) (insert ">") void] + [(= e 8211) (insert "--") void] + [(= e 8212) (insert "---") void] + + [else (insert (format "&#~a;" e)) + void]))] + + ;; ======================================== + ;; This is the main formatting function. + ;; It consumes: + ;; e : xexpr - the HTML content + ;; para-base : num - a marker for a paragraph start (e.g., + ;; the bullet for
  • ), though the actual + ;; paragraph start may be later + ;; enum-depth : num - current depth of enumerations + ;; The result is a function of no arguments that finalizes + ;; the region for `e', which normally means applying font changes. + ;; (The changes have to be applied outside-in, so that local + ;; specifications override enclosing ones.) + ;; Translate must not modify any existing text, and the + ;; result function must not move any items. + [translate + (lambda (e para-base enum-depth forced-lines form) + (cond + [(string? e) + (let ([lp (current-pos)]) + (insert e) + ;; we change the style here directly + ;; since we want this style to only appear + ;; if the style is overridden by the context + (change-style delta:default-face + lp + (+ lp (string-length e))) + (values void + 0))] + [(symbol? e) + (let ([a (entity-name->integer e)]) + (if a + (values (translate-number a) 0) + (begin + (insert (format "&~a;" e)) + (values void 0))))] + [(number? e) + (values (translate-number e) 0)] + [(or (comment? e) (pi? e)) (values void forced-lines)] + [else (let* ([tag (car e)] + [rest/base/depth/form/fl + (lambda (para-base enum-depth form forced-lines) + (let* ([p (foldl (lambda (x p) + (let-values ([(f fl) (translate x para-base enum-depth (car p) form)]) + (cons fl (cons f (cdr p))))) + (cons forced-lines null) + (cddr e))] + [l (reverse (cdr p))]) + (values (lambda () + (map (lambda (f) (f)) l)) + (car p))))] + [rest/base/depth + (lambda (para-base enum-depth) + (rest/base/depth/form/fl para-base enum-depth form forced-lines))] + [rest/form (lambda (form) (rest/base/depth/form/fl para-base enum-depth form forced-lines))] + [rest/form (lambda (form) (rest/base/depth/form/fl para-base enum-depth form forced-lines))] + [rest (lambda () (rest/base/depth/form/fl para-base enum-depth form forced-lines))] + [rest/fl (lambda (fl) (rest/base/depth/form/fl para-base enum-depth form fl))]) + (case tag + [(title) + (let ([pos (current-pos)]) + ;; Render content + (rest) + (send a-text set-title (send a-text get-text pos (current-pos))) + (delete pos (current-pos))) + (values void forced-lines)] + [(a) + (let-values ([(url-string label scheme) (parse-href e)]) + (let* ([style (get-field e 'style)] + [pos (current-pos)]) + (let-values ([(r rfl) (rest)]) + (let ([end-pos (current-pos)]) + (cond + [url-string + (send a-text add-link pos end-pos (regexp-replace* re:amp url-string "\\&")) + ;; might have a label, too: + (when label + (send a-text add-tag label pos)) + (values + (lambda () + (when (or (not style) + (not (regexp-match re:transparent style))) + (send a-text make-link-style pos end-pos)) + (r)) + rfl)] + [label + (send a-text add-tag label pos) + (values r rfl)] + [scheme + (send a-text add-scheme-callback pos end-pos scheme) + (values + (lambda () + (when (or (not style) + (not (regexp-match re:transparent style))) + (send a-text make-link-style pos end-pos)) + (r)) + rfl)] + [else (values r rfl)])))))] + [(style) (values void forced-lines)] + [(h1) (heading delta:h1 forced-lines rest para-base)] + [(h2) (heading delta:h2 forced-lines rest para-base)] + [(h3) (heading delta:h3 forced-lines rest para-base)] + [(h4) (heading delta:h4 forced-lines rest para-base)] + [(b strong) (styler delta:bold rest)] + [(i em var dfn cite) (styler delta:italic rest)] + [(u) (styler delta:underline rest)] + [(sup) (styler delta:superscript rest)] + [(sub) (styler delta:subscript rest)] + [(small) (styler delta:small rest)] + [(font) + (let ([delta (parse-font e)]) + (if delta + (styler delta rest) + (rest)))] + [(li dd dt) + (insert-newlines 1 forced-lines para-base) + (let ([pos (current-pos)] + [bullet? (eq? tag 'li)]) + (when bullet? + (let ([before (current-pos)]) + (insert (make-object bullet-snip% (sub1 enum-depth))) + (change-style (send (send a-text get-style-list) find-named-style "Standard") + before + (+ before 1)))) + (let*-values ([(r rfl) (rest/base/depth (add1 pos) enum-depth)] + [(end-pos) (current-pos)]) + (values + (lambda () + (let ([end-para (send a-text position-paragraph + (backover-newlines end-pos pos))] + [left-margin (* 2 (get-bullet-width) enum-depth)]) + (let loop ([para (send a-text position-paragraph pos)] + [first? #t]) + (send a-text set-paragraph-margins + para + (if first? + (max 0 (- left-margin + (if bullet? + (get-bullet-width) + 0))) + left-margin) + left-margin + 0) + (unless (= para end-para) + (loop (add1 para) #f)))) + (r)) + rfl)))] + [(ul menu ol dl) + (insert-newlines (if (zero? enum-depth) 2 1) forced-lines para-base) + (let-values ([(r rfl) + (rest/base/depth para-base (add1 enum-depth))]) + (insert-newlines (if (zero? enum-depth) 2 1) rfl para-base) + (values r rfl))] + [(p) + (insert-newlines 2 forced-lines para-base) + (let-values ([(r rfl) (rest)]) + (insert-newlines 2 rfl para-base) + (values r rfl))] + [(blockquote) + (insert-newlines 2 forced-lines para-base) + (let*-values ([(pos) (current-pos)] + [(r rfl) (rest/base/depth para-base (add1 enum-depth))] + [(end-pos) (current-pos)]) + (begin0 + (values + (lambda () + (let ([end-para (send a-text position-paragraph + (backover-newlines end-pos pos))] + [left-margin (* 2 (get-bullet-width) (add1 enum-depth))]) + (let loop ([para (send a-text position-paragraph pos)]) + (send a-text set-paragraph-margins + para + left-margin + left-margin + left-margin) + (unless (= para end-para) + (loop (add1 para))))) + (r)) + rfl) + (insert-newlines 2 rfl para-base)))] + [(center) + (insert-newlines 2 forced-lines para-base) + (let-values ([(r rfl) + (para-aligner 'center #f rest)]) + (insert-newlines 2 rfl para-base) + (values r rfl))] + [(div) + (insert-newlines 1 forced-lines para-base) + (let* ([align (get-field e 'align)] + [class (get-field e 'class)] + [delta (and class (lookup-class-delta class))]) + (with-style-class + class + (lambda () + (let-values ([(r rfl) + (cond + [(and (string? align) (string-ci=? align "center")) + (para-aligner 'center delta rest)] + [(and (string? align) (string-ci=? align "left")) + (para-aligner 'left delta rest)] + [(and (string? align) (string-ci=? align "left-outdent")) + (para-aligner 'left-outdent delta rest)] + [(or (and (string? align) (string-ci=? align "right")) + (and (string? class) (string-ci=? class "navigation"))) + (para-aligner 'right delta rest)] + [delta + (styler delta rest)] + [else (rest)])]) + (insert-newlines 1 rfl para-base) + (values r rfl)))))] + [(br) + (insert-newlines 1 (+ 1 forced-lines) para-base) + (rest/fl (+ forced-lines 1))] + [(table) + (insert-newlines 1 forced-lines para-base) + (let-values ([(r rfl) + (maybe-bg-color e rest #t)]) + (insert-newlines 1 rfl para-base) + (values r (max 1 rfl)))] + [(tr) + (insert-newlines 1 forced-lines para-base) + (let-values ([(r rfl) + (maybe-bg-color e rest #t)]) + (insert-newlines 1 rfl para-base) + (values r rfl))] + [(td) + (maybe-bg-color e rest #t)] + [(map) + (set! image-maps (cons e image-maps)) + (rest)] + [(img) + (let* ([url (parse-image-source e)] + [alt (get-field e 'alt)] + [bitmap (and url (cache-bitmap url))] + [usemap (get-field e 'usemap)]) + (cond + [(and bitmap usemap) + (let ([pos (current-pos)] + [image-map-snip (make-object image-map-snip% a-text)]) + (send image-map-snip set-bitmap bitmap) + (send image-map-snip set-key usemap) + (insert image-map-snip) + (set! image-map-snips (cons image-map-snip image-map-snips)) + (change-style delta:center pos (add1 pos)))] + [bitmap + (let ([pos (current-pos)]) + (insert (make-object image-snip% bitmap)) + (change-style delta:center pos (add1 pos)))] + [alt + (insert alt)] + [else + (let ([pos (current-pos)]) + (insert (new image-snip%)) + (change-style delta:center pos (add1 pos)))]) + (rest))] + [(form) + (rest/form (make-form (get-field e 'action) (get-field e 'target) (get-field e 'method) null #f))] + [(input select textarea) + (let ([unsupported (make-unsupported tag e)] + [pos (current-pos)] + [type (let ([t (get-field e 'type)]) + (and t (string->symbol t)))] + [send-form (lambda (add-self?) + (let ([post-string + (apply + string-append + (map (lambda (v) + (if (car v) + (format "~a=~a&" + (car v) + (protect-chars (or ((cdr v)) + "?"))) + "")) + (form-parts form)))]) + (send a-text post-url + (form-action form) + (string->bytes/utf-8 + (if add-self? + ;; Add this button + (format "~a~a=~a" + post-string + (get-field e 'name) + (protect-chars (get-field e 'value))) + ;; remove trailing & + (substring post-string + 0 + (max 0 (sub1 (string-length post-string)))))))))]) + (let-values ([(name cb get-val) + (cond + [(eq? tag 'select) + (let ([select (make-object option-snip%)]) + (set-form-active-select! form select) + (insert select) + (values (get-field e 'name) + #f + (lambda () + (send select get-value))))] + [(or (and (eq? tag 'input) + (or (not type) (eq? type 'text))) + (eq? tag 'textarea)) + (let* ([text (make-object text%)] + [snip (make-object editor-snip% text)] + [size (get-field e 'size)] + [val (get-field e 'value)]) + (let ([km (send text get-keymap)]) + ((current-text-keymap-initializer) km) + (unless (eq? tag 'textarea) + (send km add-function "send-form" + (lambda (t e) + (send-form #f))) + (send km map-function "enter" "send-form"))) + (let ([width (* 10 (or (and size (string->number size)) + 25))]) + (send text set-min-width width) + (send text set-max-width width)) + (when val + (send text insert val)) + (insert snip) + (values + (get-field e 'name) + #f + (lambda () (send text get-text))))] + [(and (eq? tag 'input) + (eq? type 'submit)) + (insert (get-field e 'value)) + (values + #f ; because we leave out this button when it's not pushed + (lambda () + (send-form #t)) + #f)] + [(and (eq? tag 'input) + (eq? type 'checkbox)) + (let ([cb (make-object checkbox-snip% (true? (or (get-field e 'value) "false")))]) + (insert cb) + (values + (get-field e 'name) + #f + (lambda () (if (send cb get-value) + "true" + "false"))))] + [(and (eq? tag 'input) + (eq? type 'hidden)) + (values + (get-field e 'name) + #f + (lambda () (regexp-replace* re:quot (get-field e 'value) "\"")))] + [else + (insert unsupported) + (values #f #f #f)])]) + (set-form-parts! form + (cons (cons name + (or get-val + (lambda () + (get-field e 'value)))) + (form-parts form))) + (let-values ([(r rfl) (rest)] + [(end-pos) (current-pos)]) + (set-form-active-select! form #f) + (values + (lambda () + (cond + [cb + (send a-text make-link-style pos end-pos) + (send a-text add-thunk-callback pos end-pos cb)] + [else + (change-style delta:default-face pos end-pos)]) + (r)) + rfl))))] + [(option) + (let-values ([(pos) (current-pos)] + [(r rfl) (rest)] + [(val) (get-field e 'value)] + [(selected?) (true? (or (get-field e 'selected) + "false"))] + [(end-pos) (current-pos)]) + (let ([str (send a-text get-text pos end-pos)] + [select (form-active-select form)]) + (delete pos end-pos) + (when select + (send select add-option str (or val str)) + (when selected? + (send select set-value val))) + (values r rfl)))] + [(tt code samp kbd pre) + (when (memq tag '(pre)) + (insert-newlines 2 forced-lines para-base)) + (let-values ([(r rfl) + (let* ([class (get-field e 'class)] + [delta (and class (lookup-class-delta class))]) + (with-style-class + class + (lambda () + (styler (if delta + (let ([d (make-object style-delta% 'change-nothing)]) + (send d copy delta) + (send d collapse delta:fixed) + d) + delta:fixed) + rest))))]) + (when (memq tag '(pre)) + (insert-newlines 2 rfl para-base)) + (values r rfl))] + [(span) + (let* ([class (get-field e 'class)] + [delta (and class (lookup-class-delta class))]) + (if delta + (styler delta rest) + (rest)))] + [else (rest)]))]))]) + (load-status #f "page" (send a-text get-url)) + (let-values ([(f fl) (translate content 0 0 0 (make-form #f #f #f null #f))]) + (f)) + (send a-text add-tag "top" 0) + (update-image-maps image-map-snips image-maps) + (send a-text set-position 0)))))) diff --git a/collects/browser/private/hyper.ss b/collects/browser/private/hyper.ss index e097a0b3a3..2e4b9fcc82 100644 --- a/collects/browser/private/hyper.ss +++ b/collects/browser/private/hyper.ss @@ -30,1131 +30,1133 @@ A test case: #lang scheme/unit - (require (lib "class.ss") - "sig.ss" - (lib "file.ss") - (lib "list.ss") - (lib "string.ss") - (lib "etc.ss") - (lib "url-sig.ss" "net") - (lib "url-structs.ss" "net") - (lib "head.ss" "net") - (lib "mred-sig.ss" "mred") - (lib "framework.ss" "framework") - (lib "string-constant.ss" "string-constants") - (lib "plt-installer-sig.ss" "setup")) - - - (import html^ - mred^ - setup:plt-installer^ - url^) - (export hyper^) - (init-depend mred^) - - (define-struct (exn:file-saved-instead exn) (pathname)) - (define-struct (exn:cancelled exn) ()) - (define-struct (exn:tcp-problem exn) ()) - - (define history-limit 20) - - (define-struct hyperlink (anchor-start anchor-end url-string)) - - (define-struct hypertag (name position)) +(require (lib "class.ss") + "sig.ss" + scheme/file + (lib "url-sig.ss" "net") + (lib "url-structs.ss" "net") + (lib "head.ss" "net") + (lib "mred-sig.ss" "mred") + (lib "framework.ss" "framework") + (lib "string-constant.ss" "string-constants") + (lib "plt-installer-sig.ss" "setup")) - (define (same-page-url? a b) - (or (eq? a b) - (and (url? a) (url? b) - ;; fragment can be different - (equal? (url-scheme a) (url-scheme b)) - (equal? (url-host a) (url-host b)) - - ;; assume that url-paths are all strings - ;; (other wise the pages are treated as different) - (equal? (map path/param-path (url-path a)) - (map path/param-path (url-path b))) - - (equal? (url-query a) (url-query b))))) - + +(import html^ + mred^ + setup:plt-installer^ + url^) +(export hyper^) +(init-depend mred^) - (define hyper-text<%> - (interface () - init-browser-status-line - update-browser-status-line - close-browser-status-line - url-allows-evaling?)) - - (define hyper-text-mixin - (mixin ((class->interface text%) editor:keymap<%>) (hyper-text<%>) - (inherit begin-edit-sequence end-edit-sequence lock erase clear-undos - change-style - set-modified auto-wrap - find-snip get-snip-position set-clickback get-canvas - insert last-position hide-caret - get-end-position set-autowrap-bitmap) - - (init-field url top-level-window) - (init progress) - (init-field [post-data #f]) - - (define/pubment (url-allows-evaling? url) - (cond - [(port? url) #f] - [(and (url? url) - (equal? "file" (url-scheme url))) - (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) - (path-below? - (normal-case-path (normalize-path (build-path (collection-path "mzlib") - 'up - 'up))) - (normal-case-path (normalize-path (apply build-path - (map path/param-path (url-path url)))))))] - [else (inner #f url-allows-evaling? url)])) - - (define doc-notes null) - (define title #f) - (define htmling? #f) - (define redirection #f) - (define hypertags-list (list (make-hypertag "top" 0))) - (define hyper-delta (make-object style-delta% 'change-underline #t)) - (let ([mult (send hyper-delta get-foreground-mult)] - [add (send hyper-delta get-foreground-add)]) - (send mult set 0 0 0) - (send add set 0 0 255)) - - (define/override (get-keymaps) (list* space-page-keymap hyper-keymap (super get-keymaps))) - (define/public (get-hyper-keymap) hyper-keymap) - - (define/augment (after-set-position) - (unless (zero? (get-end-position)) - (hide-caret #f)) - (inner (void) after-set-position)) +(define (last-pair l) + (if (null? (cdr l)) + l + (last-pair (cdr l)))) - ;; get-redirection : -> (union false? url?) - ;; #f indicates no redirection, url is where it redirects to - (define/public (get-redirection) redirection) - - (define/public (add-document-note note) - (set! doc-notes (append doc-notes (list note)))) - (define/public (get-document-notes) doc-notes) - - (define/public (make-link-style start end) (change-style hyper-delta start end)) - (define/public (get-url) (and (url? url) url)) - - (define/public post-url - (opt-lambda (url-string [post-data #f]) - (on-url-click - (lambda (url-string post-data) - (send (get-canvas) goto-url url-string (get-url) void post-data)) - url-string - post-data))) - - (define/public (on-url-click f x post-data) - (let ([c (get-canvas)]) - (if c - (send c on-url-click f x post-data) - (f x post-data)))) - (define/public (get-title) (or title (and (url? url) (url->string url)))) - (define/public (set-title t) (set! title t)) - - (define/public (add-tag name pos) - (for-each (lambda (tag) - (when (string=? name (hypertag-name tag)) - (remove-tag name))) - hypertags-list) - (let ([new-tag (make-hypertag name pos)]) - (set! hypertags-list - (let insert-loop ([tags-left hypertags-list]) - (cond [(null? tags-left)(cons new-tag ())] - [(> pos (hypertag-position (car tags-left))) - (cons new-tag tags-left)] - [else (cons (car tags-left) - (insert-loop (cdr tags-left)))]))))) - - (define/public (find-tag name) - (if (and (integer? name) (positive? name)) - name - (and (string? name) - (ormap (lambda (x) - (and (string=? name (hypertag-name x)) - (hypertag-position x))) - hypertags-list)))) - (define/public (remove-tag name) - (set! hypertags-list - (filter (lambda (x) (not (string=? name (hypertag-name x)))) - hypertags-list))) - (define/public (add-link start end url-string) - (let* ([new-link (make-hyperlink start end url-string)]) - (set-clickback start end - (lambda (x y z) - (post-url url-string))))) - - ;; remember the directory when the callback is added (during parsing) - ;; and restore it during the evaluation of the callback. - (define/public (add-scheme-callback start end scheme-string) - (let ([dir (current-load-relative-directory)]) - (set-clickback - start end - (lambda (edit start end) - (if (url-allows-evaling? url) - (parameterize ([current-load-relative-directory dir]) - (eval-scheme-string scheme-string)) - (message-box (string-constant help-desk) - " disabled")))))) - (define/public (add-thunk-callback start end thunk) - (set-clickback - start end - (lambda (edit start end) - (thunk)))) - - (define/public (eval-scheme-string s) - (let ([v - (dynamic-wind - begin-busy-cursor - (lambda () - (with-handlers ([exn:fail? (build-html-error-message s)]) - (eval-string s))) - end-busy-cursor)]) - (when (string? v) - (send (get-canvas) goto-url - (open-input-string v) - (get-url))))) - - (define/public (init-browser-status-line top-level-window) - (send top-level-window open-status-line 'browser:hyper.ss)) - (define/public (update-browser-status-line top-level-window s) - (send top-level-window update-status-line 'browser:hyper.ss s)) - (define/public (close-browser-status-line top-level-window) - (send top-level-window close-status-line 'browser:hyper.ss)) - - (define/public reload - ;; The reload function is called in a non-main thread, - ;; since this class is instantiated in a non-main thread. - (opt-lambda ([progress void]) - (when url - (let ([s (make-semaphore)] - [closer-t #f] - [this-t (current-thread)]) - (when top-level-window - (queue-callback - (lambda () - (init-browser-status-line top-level-window) - (update-browser-status-line - top-level-window - (format "Visiting ~a" - (cond - [(url? url) (url->string url)] - [else "page"]))) - ;; Yikes! We need to ensure that the browser status - ;; line is closed, even if the reload thread dies. - ;; We use the usual trick of setting up a watcher - ;; thread and then killing it off if its work - ;; is not needed. - (set! closer-t - (thread (lambda () - (sync (thread-dead-evt this-t)) - (queue-callback - (lambda () - (close-browser-status-line top-level-window)))))) - (semaphore-post s))) - (yield s)) - (let ([headers (get-headers/read-from-port progress)]) - ;; Page is a redirection? - (let ([m (regexp-match "^HTTP/[^ ]+ 30[12] " headers)]) - (when m - (let ([loc (extract-field "location" headers)]) - (when loc - (set! redirection - (cond - [(url? url) - (combine-url/relative url loc)] - [else - (string->url loc)]))))))) - (when top-level-window - (queue-callback - (lambda () - (kill-thread closer-t) - (close-browser-status-line top-level-window) - (semaphore-post s))) - (yield s)))))) - - (define/private (get-headers/read-from-port progress) - (cond - [(port? url) - (read-from-port url empty-header progress) - empty-header] - [else - (let* ([busy? #t] - [stop-busy (lambda () - (when busy? - (set! busy? #f)))]) - (with-handlers ([(lambda (x) (and (exn:fail? x) busy?)) - (lambda (x) - (call/input-url - url - (if post-data - (case-lambda - [(u) (post-pure-port u post-data)] - [(u s) (post-pure-port u post-data s)]) - get-pure-port) - (lambda (p) - (stop-busy) - (read-from-port p empty-header progress) - empty-header)))]) - (call/input-url - url - (if post-data - (case-lambda - [(u) (post-impure-port u post-data)] - [(u s) (post-impure-port u post-data s)]) - get-impure-port) - (lambda (p) - (let ([headers (purify-port p)]) - (stop-busy) - (read-from-port p headers progress) - headers)))))])) - - (define/private (read-from-port p mime-headers progress) - (let ([wrapping-on? #t]) - (dynamic-wind - (lambda () - (lock #f) - (begin-edit-sequence #f) - (set! htmling? #t)) - (lambda () - (erase) - (clear-undos) - (let* ([mime-type (extract-field "content-type" mime-headers)] - [path-extension (and (not mime-type) - (url? url) - (let ([p (url-path url)]) - (and (not (null? p)) - (regexp-match #rx"[.][^.]*$" - (path/param-path (car (last-pair p)))))))] - [html? (or (and mime-type (regexp-match #rx"text/html" mime-type)) - (member path-extension '(".html" ".htm")))] - [text? (or (and mime-type (regexp-match #rx"text/plain" mime-type)) - (member path-extension '(".txt")) - (and (url? url) - (equal? (url-scheme url) "file")))]) - (cond - [(or (and mime-type (regexp-match #rx"application/" mime-type)) - (and (url? url) - (not (null? (url-path url))) - (not text?) - ; document-not-found produces HTML: - (not html?))) - ; Save the file - (progress #f) - (let* ([orig-name (and (url? url) - (let ([p (url-path url)]) - (and (not (null? p)) - (let ([lp (path/param-path (car (last-pair p)))]) - (and (not (string=? "" lp)) - lp)))))] - [size (let ([s (extract-field "content-length" mime-headers)]) - (and s (let ([m (regexp-match #rx"[0-9]+" s)]) - (and m (string->number (car m))))))] - [install? - (and (and orig-name (regexp-match #rx"[.]plt$" orig-name)) - (let ([d (make-object dialog% (string-constant install?))] - [d? #f] - [i? #f]) - (make-object message% - (string-constant you-have-selected-an-installable-package) - d) - (make-object message% - (string-constant do-you-want-to-install-it?) d) - (when size - (make-object message% - (format (string-constant paren-file-size) size) d)) - (let ([hp (make-object horizontal-panel% d)]) - (send hp set-alignment 'center 'center) - (send (make-object button% - (string-constant download-and-install) - hp - (lambda (b e) - (set! i? #t) - (send d show #f)) - '(border)) - focus) - (make-object button% (string-constant download) hp - (lambda (b e) - (set! d? #t) - (send d show #f))) - (make-object button% (string-constant cancel) hp - (lambda (b e) - (send d show #f)))) - (send d center) - (send d show #t) - (unless (or d? i?) - (raise (make-exn:cancelled - "Package Cancelled" - (current-continuation-marks)))) - i?))] - [tmp-plt-filename - (if install? - (make-temporary-file "tmp~a.plt") - (put-file - (if size - (format - (string-constant save-downloaded-file/size) - size) - (string-constant save-downloaded-file)) - #f ; should be calling window! - #f - orig-name))]) - (when tmp-plt-filename - (let* ([d (make-object dialog% (string-constant downloading) top-level-window)] - [message (make-object message% - (string-constant downloading-file...) - d)] - [gauge (if size - (make-object gauge% #f 100 d) - #f)] - [exn #f] - ; Semaphores to avoid race conditions: - [wait-to-start (make-semaphore 0)] - [wait-to-break (make-semaphore 0)] - ; Thread to perform the download: - [t (thread - (lambda () - (semaphore-wait wait-to-start) - (with-handlers ([void - (lambda (x) - (when (not (exn:break? x)) - (set! exn x)))]) - (semaphore-post wait-to-break) - (with-output-to-file tmp-plt-filename - (lambda () - (let loop ([total 0]) - (when gauge - (send gauge set-value - (inexact->exact - (floor (* 100 (/ total size)))))) - (let ([bts (read-bytes 1024 p)]) - (unless (eof-object? bts) - (write-bytes bts) - (loop (+ total (bytes-length bts))))))) - 'binary 'truncate)) - (send d show #f)))]) - (send d center) - (make-object button% (string-constant &stop) - d (lambda (b e) - (semaphore-wait wait-to-break) - (set! tmp-plt-filename #f) - (send d show #f) - (break-thread t))) - ; Let thread run only after the dialog is shown - (queue-callback (lambda () (semaphore-post wait-to-start))) - (send d show #t) - (when exn - (raise (make-exn:tcp-problem (exn-message exn) (current-continuation-marks))))) - (let ([sema (make-semaphore 0)]) - (when (and tmp-plt-filename install?) - (run-installer tmp-plt-filename - (lambda () - (semaphore-post sema))) - (yield sema)))) - (raise - (if tmp-plt-filename - (make-exn:file-saved-instead - (if install? - (string-constant package-was-installed) - (string-constant download-was-saved)) - (current-continuation-marks) - tmp-plt-filename) - (make-exn:cancelled "The download was cancelled." - (current-continuation-marks)))))] - [(or (and (url? url) - (not (null? (url-path url))) - (regexp-match #rx"[.]html?$" - (path/param-path (car (last-pair (url-path url)))))) - (port? url) - html?) - ; HTML - (progress #t) - (let* ([directory - (or (if (and (url? url) - (string=? "file" (url-scheme url))) - (let ([path (apply build-path (map path/param-path (url-path url)))]) - (let-values ([(base name dir?) (split-path path)]) - (if (string? base) - base - #f))) - #f) - (current-load-relative-directory))]) - (parameterize ([html-status-handler - (lambda (s) - (when top-level-window - (let ([t (current-thread)] - [sema (make-semaphore)]) - (queue-callback - (lambda () - (when (thread-running? t) - ;; Since t is running, the status line hasn't been - ;; closed by the watcher thread (and there's no - ;; race, because it can only be closed in the - ;; handler thread) - (update-browser-status-line top-level-window s)) - (semaphore-post sema))) - (yield sema))))] - [current-load-relative-directory directory] - [html-eval-ok (url-allows-evaling? url)]) - (html-convert p this)))] - [else - ; Text - (progress #t) - (begin-edit-sequence) - (let loop () - (let ([r (read-line p 'any)]) - (unless (eof-object? r) - (insert r) - (insert #\newline) - (loop)))) - (change-style (make-object style-delta% 'change-family 'modern) - 0 (last-position)) - (set! wrapping-on? #f) - (end-edit-sequence)]))) - (lambda () - (end-edit-sequence) - (set! htmling? #f) - (set-modified #f) - (auto-wrap wrapping-on?) - (set-autowrap-bitmap #f) - (lock #t) - (close-input-port p))))) - - (inherit find-position get-snip-location - get-dc get-between-threshold - editor-location-to-dc-location - dc-location-to-editor-location) - ;; use on-event rather than on-default-event since we want - ;; to override the caret handling snip in the case that - ;; an image-map-snip is there. - (define/override (on-event event) - (let* ([edge-close-b (box 0)] - [on-it-b (box #f)] - [dc-event-x (send event get-x)] - [dc-event-y (send event get-y)]) - (let-values ([(editor-event-x editor-event-y) - (dc-location-to-editor-location dc-event-x dc-event-y)]) - (let ([pos (find-position editor-event-x editor-event-y #f on-it-b edge-close-b)]) - (cond - [(and (unbox on-it-b) - (not (<= (abs (unbox edge-close-b)) - (get-between-threshold)))) - (let ([snip (find-snip pos 'after-or-none)]) - (cond - [(and snip (is-a? snip image-map-snip%)) - (let ([bsnip-left (box 0)] - [bsnip-top (box 0)] - [bsnip-right (box 0)] - [bsnip-bot (box 0)]) - (get-snip-location snip bsnip-left bsnip-top #f) - (get-snip-location snip bsnip-right bsnip-bot #t) - (let ([snip-left (unbox bsnip-left)] - [snip-top (unbox bsnip-top)] - [snip-right (unbox bsnip-right)] - [snip-bot (unbox bsnip-bot)]) - (cond - [(and (<= snip-left editor-event-x snip-right) - (<= snip-top editor-event-y snip-bot)) - (let-values ([(x y) (editor-location-to-dc-location snip-left snip-top)]) - (send snip on-event (get-dc) x y snip-left snip-top event))] - [else (super on-event event)])))] - [else (super on-event event)]))] - [else (super on-event event)]))))) - - (super-new) - - ;; load url, but the user might break: - (with-handlers ([exn:break? void]) - ;(printf "url: ~a\n" (if (url? url) (url->string url) url)) ;; handy for debugging help desk - (reload progress)))) - - ;; build-html-error-message : exn -> string[html] - (define ((build-html-error-message str) exn) - (string-append - "Error Evaluating Scheme" - "" - "

    Error Evaluating Scheme Code

    " - (format "
    \n~a\n
    " str) - "

    " - (format "~a" - (regexp-replace* #rx"<" (regexp-replace* #rx">" (exn-message exn) "<") ">")) - "")) - - (define hyper-text% (hyper-text-mixin text:keymap%)) +(define-struct (exn:file-saved-instead exn) (pathname)) +(define-struct (exn:cancelled exn) ()) +(define-struct (exn:tcp-problem exn) ()) - (define space-page-keymap (make-object keymap%)) - (add-text-keymap-functions space-page-keymap) - (send space-page-keymap map-function "space" "next-page") - (send space-page-keymap map-function "s:space" "previous-page") - - (define hyper-keymap (make-object keymap%)) - (send hyper-keymap add-function "rewind" - (lambda (txt evt) - (call-with-hyper-panel - txt - (lambda (panel) - (send panel rewind))))) - (send hyper-keymap add-function "forward" - (lambda (txt evt) - (call-with-hyper-panel - txt - (lambda (panel) - (send panel forward))))) - (send hyper-keymap add-function "do-wheel" - (lambda (txt evt) - ;; Redirect the event to the canvas, which should - ;; handle the event - (send (send txt get-canvas) on-char evt))) - (add-text-keymap-functions hyper-keymap) - (send hyper-keymap map-function "d:[" "rewind") - (send hyper-keymap map-function "a:[" "rewind") - (send hyper-keymap map-function "c:[" "rewind") - (send hyper-keymap map-function "d:left" "rewind") - (send hyper-keymap map-function "a:left" "rewind") - (send hyper-keymap map-function "c:left" "rewind") - (send hyper-keymap map-function "m:left" "rewind") - (send hyper-keymap map-function "d:]" "forward") - (send hyper-keymap map-function "a:]" "forward") - (send hyper-keymap map-function "c:]" "forward") - (send hyper-keymap map-function "d:right" "forward") - (send hyper-keymap map-function "a:right" "forward") - (send hyper-keymap map-function "c:right" "forward") - (send hyper-keymap map-function "m:right" "forward") - (send hyper-keymap map-function "wheelup" "do-wheel") - (send hyper-keymap map-function "pageup" "previous-page") - (send hyper-keymap map-function "wheeldown" "do-wheel") - (send hyper-keymap map-function "pagedown" "next-page") - - ;; call-with-hyper-panel : object ((is-a?/c hyper-panel<%>) -> void) -> void - (define (call-with-hyper-panel text f) - (when (is-a? text hyper-text<%>) - (let ([canvas (send text get-canvas)]) - (when canvas - (let ([tlw (send canvas get-top-level-window)]) - (when (is-a? tlw hyper-frame<%>) - (f (send tlw get-hyper-panel)))))))) - - ;; path-below? : string[normalized-path] string[normalized-path] -> boolean - ;; returns #t if subpath points to a place below top - (define (path-below? top longer) - (let loop ([top (explode-path top)] - [longer (explode-path longer)]) - (cond - [(null? top) #t] - [(null? longer) #f] - [(equal? (car top) (car longer)) - (loop (cdr top) (cdr longer))] - [else #f]))) +(define history-limit 20) - (keymap:add-to-right-button-menu/before - (let ([old (keymap:add-to-right-button-menu/before)]) - (lambda (menu editor event) - (when (is-a? editor hyper-text<%>) - (let* ([panel (let ([canvas (send editor get-canvas)]) - (and canvas - (send (send canvas get-top-level-window) get-hyper-panel)))] - [back - (instantiate menu-item% () - (label (string-append "< " (string-constant rewind-in-browser-history))) - (parent menu) - (callback - (lambda (_1 _2) - (when panel - (send panel rewind)))))] - [forward - (instantiate menu-item% () - (label (string-append (string-constant forward-in-browser-history) " >")) - (parent menu) - (callback - (lambda (_1 _2) - (when panel - (send panel forward)))))]) - (send back enable (send panel can-rewind?)) - (send forward enable (send panel can-forward?)) - (instantiate separator-menu-item% () - (parent menu)))) - (old menu editor event)))) - - (define hyper-canvas-mixin - (mixin ((class->interface editor-canvas%)) () - (inherit get-editor set-editor refresh get-parent get-top-level-window) - - (define/public (get-editor%) hyper-text%) - - (define/public (current-page) - (let ([e (get-editor)]) - (and e - (let ([sbox (box 0)] - [ebox (box 0)]) - (send e get-visible-position-range sbox ebox) - (list e (unbox sbox) (unbox ebox)))))) - (define/public (on-url-click k url post-data) - (send (get-parent) on-url-click k url post-data)) - (define/public goto-url - (opt-lambda (in-url relative [progress void] [post-data #f]) - (let ([tlw (get-top-level-window)]) - (when (and tlw - (is-a? tlw hyper-frame<%>)) - (let* ([pre-url (cond - [(url? in-url) in-url] - [(port? in-url) in-url] - [(string? in-url) - (if relative - (combine-url/relative relative in-url) - (string->url in-url))] - [else (error 'goto-url "unknown url ~e\n" in-url)])] - [killable-cust (make-custodian)] - [hyper-panel (send tlw get-hyper-panel)] - [result - (let ([e-now (get-editor)]) - (cond - [(and e-now - (not post-data) - (same-page-url? pre-url (send e-now get-url))) - (progress #t) - (cons e-now pre-url)] - [else - (send hyper-panel set-stop-callback - (lambda () - (custodian-shutdown-all killable-cust))) - (send hyper-panel enable-browsing #f) - (begin0 - (make-editor/setup-kill killable-cust - (get-editor%) - tlw - pre-url - progress - post-data - (lambda (x) (remap-url x))) - (send hyper-panel set-stop-callback void) - (send hyper-panel enable-browsing #t))]))]) - (cond - [(pair? result) - (let* ([e (car result)] - [url (cdr result)] - [tag-pos (send e find-tag (and (url? url) (url-fragment url)))]) - (unless (and tag-pos (positive? tag-pos)) - (send e hide-caret #t)) - (set-page (list e (or tag-pos 0) (send e last-position)) #t) - (when tag-pos (send e set-position tag-pos)))] - [(exn? result) - (message-box (string-constant drscheme) - (exn-message result) - tlw)] - [else (void)])))))) - - ;; remap-url : url? -> (union #f url?) - ;; this method is intended to be overridden so that derived classes can change - ;; the behavior of the browser. Calls to this method may be killed. - (define/public (remap-url url) - url) - - (define/public (after-set-page) (void)) - (define/public (set-page page notify?) - (let ([e (car page)] - [spos (cadr page)] - [epos (caddr page)] - [curr (get-editor)] - [current (current-page)]) - ; Pre-size the editor to avoid visible reflow - (when curr - (let ([wbox (box 0)]) - (send curr get-view-size wbox (box 0)) - (when (send e auto-wrap) - (send e set-max-width (unbox wbox))))) - (send e begin-edit-sequence) - (when notify? - (send (get-parent) leaving-page current (list e 0 0))) - (set-editor e (and current (zero? (cadr current)) (zero? spos))) - (send e scroll-to-position spos #f epos 'start) - (send e end-edit-sequence) - (after-set-page) - (when (or (positive? spos) (not current) (positive? (cadr current))) - (refresh)))) - (super-new))) - - ;; make-editor/setup-kill : custodian editor-class frame%-instance - ;; url (boolean??? -> void) ??? (url -> (union port #f url)) - ;; -> (union (cons editor (union #f url)) exn #f) - ;; if cust is shutdown, the url will stop being loaded and a dummy editor is returned. - (define (make-editor/setup-kill cust html-editor% tlw init-url progress post-data remap-url) - (let* ([c (make-channel)] - [progs (make-channel)] - [sent-prog? #f] - [t (parameterize ([current-custodian cust]) - (thread - (lambda () - (with-handlers ([exn? (lambda (exn) - (channel-put c exn))]) - (channel-put - c - (make-editor/follow-redirections html-editor% - tlw - init-url - (lambda (v) - (channel-put progs v)) - post-data - remap-url))))))] - [ans #f]) - (let loop () - (yield - (choice-evt - (handle-evt c (lambda (x) (set! ans x))) - (handle-evt progs (lambda (v) - (set! sent-prog? #t) - (progress v) - (loop))) - (handle-evt (thread-dead-evt t) - (lambda (_) - (let ([t (new hyper-text% - (url #f) - (top-level-window #f) - (progress void))]) - (send t insert "Stopped.") - (set! ans (cons t #f)))))))) - (unless sent-prog? - (progress #f)) - ans)) - - ;; make-editor/follow-redirections : editor-class frame%-instance - ;; url (boolean??? -> void) ??? (url -> (union port #f url)) - ;; -> (cons (union #f editor) (union #f url)) - ;; builds an html editor using make-editor and follows any redictions, - ;; but stops after 10 redirections (just in case there are too many - ;; of these things, give the user a chance to stop) - (define (make-editor/follow-redirections html-editor% tlw init-url progress post-data remap-url) - (with-handlers ([(lambda (x) - (or (exn:file-saved-instead? x) - (exn:cancelled? x) - (exn:tcp-problem? x))) - values]) - (let loop ([n 10] - [unmapped-url init-url]) - (let ([url (if (url? unmapped-url) - (let ([rurl (remap-url unmapped-url)]) - (unless (or (url? rurl) - (input-port? rurl) - (not rurl)) - (error 'remap-url - "expected a url struct, an input-port, or #f, got ~e" - rurl)) - rurl) - unmapped-url)]) - (if url - (let ([html-editor (new html-editor% - [url url] - [top-level-window tlw] - [progress progress] - [post-data post-data])]) - (cond - [(zero? n) - (cons html-editor url)] - [(send html-editor get-redirection) - => - (lambda (new-url) (loop (- n 1) new-url))] +(define-struct hyperlink (anchor-start anchor-end url-string)) + +(define-struct hypertag (name position)) + +(define (same-page-url? a b) + (or (eq? a b) + (and (url? a) (url? b) + ;; fragment can be different + (equal? (url-scheme a) (url-scheme b)) + (equal? (url-host a) (url-host b)) + + ;; assume that url-paths are all strings + ;; (other wise the pages are treated as different) + (equal? (map path/param-path (url-path a)) + (map path/param-path (url-path b))) + + (equal? (url-query a) (url-query b))))) + + +(define hyper-text<%> + (interface () + init-browser-status-line + update-browser-status-line + close-browser-status-line + url-allows-evaling?)) + +(define hyper-text-mixin + (mixin ((class->interface text%) editor:keymap<%>) (hyper-text<%>) + (inherit begin-edit-sequence end-edit-sequence lock erase clear-undos + change-style + set-modified auto-wrap + find-snip get-snip-position set-clickback get-canvas + insert last-position hide-caret + get-end-position set-autowrap-bitmap) + + (init-field url top-level-window) + (init progress) + (init-field [post-data #f]) + + (define/pubment (url-allows-evaling? url) + (cond + [(port? url) #f] + [(and (url? url) + (equal? "file" (url-scheme url))) + (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) + (path-below? + (normal-case-path (normalize-path (build-path (collection-path "mzlib") + 'up + 'up))) + (normal-case-path (normalize-path (apply build-path + (map path/param-path (url-path url)))))))] + [else (inner #f url-allows-evaling? url)])) + + (define doc-notes null) + (define title #f) + (define htmling? #f) + (define redirection #f) + (define hypertags-list (list (make-hypertag "top" 0))) + (define hyper-delta (make-object style-delta% 'change-underline #t)) + (let ([mult (send hyper-delta get-foreground-mult)] + [add (send hyper-delta get-foreground-add)]) + (send mult set 0 0 0) + (send add set 0 0 255)) + + (define/override (get-keymaps) (list* space-page-keymap hyper-keymap (super get-keymaps))) + (define/public (get-hyper-keymap) hyper-keymap) + + (define/augment (after-set-position) + (unless (zero? (get-end-position)) + (hide-caret #f)) + (inner (void) after-set-position)) + + ;; get-redirection : -> (union false? url?) + ;; #f indicates no redirection, url is where it redirects to + (define/public (get-redirection) redirection) + + (define/public (add-document-note note) + (set! doc-notes (append doc-notes (list note)))) + (define/public (get-document-notes) doc-notes) + + (define/public (make-link-style start end) (change-style hyper-delta start end)) + (define/public (get-url) (and (url? url) url)) + + (define/public post-url + (lambda (url-string [post-data #f]) + (on-url-click + (lambda (url-string post-data) + (send (get-canvas) goto-url url-string (get-url) void post-data)) + url-string + post-data))) + + (define/public (on-url-click f x post-data) + (let ([c (get-canvas)]) + (if c + (send c on-url-click f x post-data) + (f x post-data)))) + (define/public (get-title) (or title (and (url? url) (url->string url)))) + (define/public (set-title t) (set! title t)) + + (define/public (add-tag name pos) + (for-each (lambda (tag) + (when (string=? name (hypertag-name tag)) + (remove-tag name))) + hypertags-list) + (let ([new-tag (make-hypertag name pos)]) + (set! hypertags-list + (let insert-loop ([tags-left hypertags-list]) + (cond [(null? tags-left)(cons new-tag ())] + [(> pos (hypertag-position (car tags-left))) + (cons new-tag tags-left)] + [else (cons (car tags-left) + (insert-loop (cdr tags-left)))]))))) + + (define/public (find-tag name) + (if (and (integer? name) (positive? name)) + name + (and (string? name) + (ormap (lambda (x) + (and (string=? name (hypertag-name x)) + (hypertag-position x))) + hypertags-list)))) + (define/public (remove-tag name) + (set! hypertags-list + (filter (lambda (x) (not (string=? name (hypertag-name x)))) + hypertags-list))) + (define/public (add-link start end url-string) + (let* ([new-link (make-hyperlink start end url-string)]) + (set-clickback start end + (lambda (x y z) + (post-url url-string))))) + + ;; remember the directory when the callback is added (during parsing) + ;; and restore it during the evaluation of the callback. + (define/public (add-scheme-callback start end scheme-string) + (let ([dir (current-load-relative-directory)]) + (set-clickback + start end + (lambda (edit start end) + (if (url-allows-evaling? url) + (parameterize ([current-load-relative-directory dir]) + (eval-scheme-string scheme-string)) + (message-box (string-constant help-desk) + " disabled")))))) + (define/public (add-thunk-callback start end thunk) + (set-clickback + start end + (lambda (edit start end) + (thunk)))) + + (define/public (eval-scheme-string s) + (let ([v + (dynamic-wind + begin-busy-cursor + (lambda () + (with-handlers ([exn:fail? (build-html-error-message s)]) + (eval (read (open-input-string s))))) + end-busy-cursor)]) + (when (string? v) + (send (get-canvas) goto-url + (open-input-string v) + (get-url))))) + + (define/public (init-browser-status-line top-level-window) + (send top-level-window open-status-line 'browser:hyper.ss)) + (define/public (update-browser-status-line top-level-window s) + (send top-level-window update-status-line 'browser:hyper.ss s)) + (define/public (close-browser-status-line top-level-window) + (send top-level-window close-status-line 'browser:hyper.ss)) + + (define/public reload + ;; The reload function is called in a non-main thread, + ;; since this class is instantiated in a non-main thread. + (lambda ([progress void]) + (when url + (let ([s (make-semaphore)] + [closer-t #f] + [this-t (current-thread)]) + (when top-level-window + (queue-callback + (lambda () + (init-browser-status-line top-level-window) + (update-browser-status-line + top-level-window + (format "Visiting ~a" + (cond + [(url? url) (url->string url)] + [else "page"]))) + ;; Yikes! We need to ensure that the browser status + ;; line is closed, even if the reload thread dies. + ;; We use the usual trick of setting up a watcher + ;; thread and then killing it off if its work + ;; is not needed. + (set! closer-t + (thread (lambda () + (sync (thread-dead-evt this-t)) + (queue-callback + (lambda () + (close-browser-status-line top-level-window)))))) + (semaphore-post s))) + (yield s)) + (let ([headers (get-headers/read-from-port progress)]) + ;; Page is a redirection? + (let ([m (regexp-match "^HTTP/[^ ]+ 30[12] " headers)]) + (when m + (let ([loc (extract-field "location" headers)]) + (when loc + (set! redirection + (cond + [(url? url) + (combine-url/relative url loc)] + [else + (string->url loc)]))))))) + (when top-level-window + (queue-callback + (lambda () + (kill-thread closer-t) + (close-browser-status-line top-level-window) + (semaphore-post s))) + (yield s)))))) + + (define/private (get-headers/read-from-port progress) + (cond + [(port? url) + (read-from-port url empty-header progress) + empty-header] + [else + (let* ([busy? #t] + [stop-busy (lambda () + (when busy? + (set! busy? #f)))]) + (with-handlers ([(lambda (x) (and (exn:fail? x) busy?)) + (lambda (x) + (call/input-url + url + (if post-data + (case-lambda + [(u) (post-pure-port u post-data)] + [(u s) (post-pure-port u post-data s)]) + get-pure-port) + (lambda (p) + (stop-busy) + (read-from-port p empty-header progress) + empty-header)))]) + (call/input-url + url + (if post-data + (case-lambda + [(u) (post-impure-port u post-data)] + [(u s) (post-impure-port u post-data s)]) + get-impure-port) + (lambda (p) + (let ([headers (purify-port p)]) + (stop-busy) + (read-from-port p headers progress) + headers)))))])) + + (define/private (read-from-port p mime-headers progress) + (let ([wrapping-on? #t]) + (dynamic-wind + (lambda () + (lock #f) + (begin-edit-sequence #f) + (set! htmling? #t)) + (lambda () + (erase) + (clear-undos) + (let* ([mime-type (extract-field "content-type" mime-headers)] + [path-extension (and (not mime-type) + (url? url) + (let ([p (url-path url)]) + (and (not (null? p)) + (regexp-match #rx"[.][^.]*$" + (path/param-path (car (last-pair p)))))))] + [html? (or (and mime-type (regexp-match #rx"text/html" mime-type)) + (member path-extension '(".html" ".htm")))] + [text? (or (and mime-type (regexp-match #rx"text/plain" mime-type)) + (member path-extension '(".txt")) + (and (url? url) + (equal? (url-scheme url) "file")))]) + (cond + [(or (and mime-type (regexp-match #rx"application/" mime-type)) + (and (url? url) + (not (null? (url-path url))) + (not text?) + ; document-not-found produces HTML: + (not html?))) + ; Save the file + (progress #f) + (let* ([orig-name (and (url? url) + (let ([p (url-path url)]) + (and (not (null? p)) + (let ([lp (path/param-path (car (last-pair p)))]) + (and (not (string=? "" lp)) + lp)))))] + [size (let ([s (extract-field "content-length" mime-headers)]) + (and s (let ([m (regexp-match #rx"[0-9]+" s)]) + (and m (string->number (car m))))))] + [install? + (and (and orig-name (regexp-match #rx"[.]plt$" orig-name)) + (let ([d (make-object dialog% (string-constant install?))] + [d? #f] + [i? #f]) + (make-object message% + (string-constant you-have-selected-an-installable-package) + d) + (make-object message% + (string-constant do-you-want-to-install-it?) d) + (when size + (make-object message% + (format (string-constant paren-file-size) size) d)) + (let ([hp (make-object horizontal-panel% d)]) + (send hp set-alignment 'center 'center) + (send (make-object button% + (string-constant download-and-install) + hp + (lambda (b e) + (set! i? #t) + (send d show #f)) + '(border)) + focus) + (make-object button% (string-constant download) hp + (lambda (b e) + (set! d? #t) + (send d show #f))) + (make-object button% (string-constant cancel) hp + (lambda (b e) + (send d show #f)))) + (send d center) + (send d show #t) + (unless (or d? i?) + (raise (make-exn:cancelled + "Package Cancelled" + (current-continuation-marks)))) + i?))] + [tmp-plt-filename + (if install? + (make-temporary-file "tmp~a.plt") + (put-file + (if size + (format + (string-constant save-downloaded-file/size) + size) + (string-constant save-downloaded-file)) + #f ; should be calling window! + #f + orig-name))]) + (when tmp-plt-filename + (let* ([d (make-object dialog% (string-constant downloading) top-level-window)] + [message (make-object message% + (string-constant downloading-file...) + d)] + [gauge (if size + (make-object gauge% #f 100 d) + #f)] + [exn #f] + ; Semaphores to avoid race conditions: + [wait-to-start (make-semaphore 0)] + [wait-to-break (make-semaphore 0)] + ; Thread to perform the download: + [t (thread + (lambda () + (semaphore-wait wait-to-start) + (with-handlers ([void + (lambda (x) + (when (not (exn:break? x)) + (set! exn x)))]) + (semaphore-post wait-to-break) + (with-output-to-file tmp-plt-filename + (lambda () + (let loop ([total 0]) + (when gauge + (send gauge set-value + (inexact->exact + (floor (* 100 (/ total size)))))) + (let ([bts (read-bytes 1024 p)]) + (unless (eof-object? bts) + (write-bytes bts) + (loop (+ total (bytes-length bts))))))) + 'binary 'truncate)) + (send d show #f)))]) + (send d center) + (make-object button% (string-constant &stop) + d (lambda (b e) + (semaphore-wait wait-to-break) + (set! tmp-plt-filename #f) + (send d show #f) + (break-thread t))) + ; Let thread run only after the dialog is shown + (queue-callback (lambda () (semaphore-post wait-to-start))) + (send d show #t) + (when exn + (raise (make-exn:tcp-problem (exn-message exn) (current-continuation-marks))))) + (let ([sema (make-semaphore 0)]) + (when (and tmp-plt-filename install?) + (run-installer tmp-plt-filename + (lambda () + (semaphore-post sema))) + (yield sema)))) + (raise + (if tmp-plt-filename + (make-exn:file-saved-instead + (if install? + (string-constant package-was-installed) + (string-constant download-was-saved)) + (current-continuation-marks) + tmp-plt-filename) + (make-exn:cancelled "The download was cancelled." + (current-continuation-marks)))))] + [(or (and (url? url) + (not (null? (url-path url))) + (regexp-match #rx"[.]html?$" + (path/param-path (car (last-pair (url-path url)))))) + (port? url) + html?) + ; HTML + (progress #t) + (let* ([directory + (or (if (and (url? url) + (string=? "file" (url-scheme url))) + (let ([path (apply build-path (map path/param-path (url-path url)))]) + (let-values ([(base name dir?) (split-path path)]) + (if (string? base) + base + #f))) + #f) + (current-load-relative-directory))]) + (parameterize ([html-status-handler + (lambda (s) + (when top-level-window + (let ([t (current-thread)] + [sema (make-semaphore)]) + (queue-callback + (lambda () + (when (thread-running? t) + ;; Since t is running, the status line hasn't been + ;; closed by the watcher thread (and there's no + ;; race, because it can only be closed in the + ;; handler thread) + (update-browser-status-line top-level-window s)) + (semaphore-post sema))) + (yield sema))))] + [current-load-relative-directory directory] + [html-eval-ok (url-allows-evaling? url)]) + (html-convert p this)))] [else - (cons html-editor url)])) - #f))))) - - (define hyper-canvas% (hyper-canvas-mixin canvas:basic%)) - - (define info-canvas% - (class canvas% - (inherit min-client-height get-dc stretchable-height - get-parent enable refresh show) - (field - [text ""]) - [define/override on-paint - (lambda () - (let ([dc (get-dc)]) - (send dc clear) - (send dc draw-text text 4 2)))] - [define/public erase-info (lambda () - (unless (string=? text "") - (set! text "") - (let ([dc (get-dc)]) - (send dc clear))))] - [define/public set-info (lambda (t) - (set! text t) - (if (string=? t "") - (show #f) - (let ([dc (get-dc)]) - (send dc clear) - (show #t) - (refresh))))] - (super-instantiate ()) - (stretchable-height #f) - (enable #f) - (show #f) - (let ([font (make-object font% (send normal-control-font get-point-size) - 'default 'normal 'normal)] - [dc (get-dc)]) - (send dc set-font font) - (send dc set-text-foreground (make-object color% "FOREST GREEN")) - (let-values ([(w h d a) (send dc get-text-extent "X" font)]) - (min-client-height (+ 4 (inexact->exact (ceiling h)))))))) - - (define hyper-panel<%> - (interface () - current-page - rewind - forward - can-rewind? - can-forward? - get-canvas% - make-canvas - make-control-bar-panel - - set-init-page - goto-init-page - - on-navigate - filter-notes - get-canvas - on-url-click - reload - leaving-page - get-stop-button - set-stop-callback - - enable-browsing)) - - (define hyper-panel-mixin - (mixin (area-container<%>) (hyper-panel<%>) - (init info-line?) - (inherit reflow-container) - (super-new) - - (define browsing-on? #t) - (define/public (enable-browsing on?) - (set! browsing-on? on?) - (cond - [on? - (send stop-button enable #f) - (when choice (send choice enable #t)) - (update-buttons)] - [else - (send stop-button enable #t) - (when home (send home enable #f)) - (when forw (send forw enable #f)) - (when back (send back enable #f)) - (when choice (send choice enable #f))])) - - (define/private (clear-info) - (when info - (send info erase-info))) - (define/private (update-info page) - (when (and info page) - (let ([notes (send (page->editor page) get-document-notes)]) - (send info set-info - (filter-notes notes (send (page->editor page) get-url)))))) - (define/private (go page) - (clear-info) - (send c set-page page #f) - (update-info page) - (update-buttons/set-page page) - (on-navigate)) - - (define/public (current-page) (send c current-page)) - (define/public (rewind) - (unless (null? past) - (let ([page (car past)]) - (set! future (cons (send c current-page) future)) - (set! past (cdr past)) - (go page)))) - (define/public (forward) - (unless (null? future) - (let ([page (car future)]) - (set! past (cons (send c current-page) past)) - (set! future (cdr future)) - (go page)))) - (define/public (can-forward?) (and browsing-on? (not (null? future)))) - (define/public (can-rewind?) (and browsing-on? (not (null? past)))) - [define/public get-canvas% (lambda () hyper-canvas%)] - [define/public make-canvas (lambda (f) (make-object (get-canvas%) f))] - [define/public make-control-bar-panel (lambda (f) (make-object horizontal-panel% f))] - (field - [past null] - [future null] - - - ;; (union #f -- no init page - ;; string -- delayed init page - ;; url -- delayed init page - ;; (list editor number numer)) -- forced init page - [init-page #f] + ; Text + (progress #t) + (begin-edit-sequence) + (let loop () + (let ([r (read-line p 'any)]) + (unless (eof-object? r) + (insert r) + (insert #\newline) + (loop)))) + (change-style (make-object style-delta% 'change-family 'modern) + 0 (last-position)) + (set! wrapping-on? #f) + (end-edit-sequence)]))) + (lambda () + (end-edit-sequence) + (set! htmling? #f) + (set-modified #f) + (auto-wrap wrapping-on?) + (set-autowrap-bitmap #f) + (lock #t) + (close-input-port p))))) + + (inherit find-position get-snip-location + get-dc get-between-threshold + editor-location-to-dc-location + dc-location-to-editor-location) + ;; use on-event rather than on-default-event since we want + ;; to override the caret handling snip in the case that + ;; an image-map-snip is there. + (define/override (on-event event) + (let* ([edge-close-b (box 0)] + [on-it-b (box #f)] + [dc-event-x (send event get-x)] + [dc-event-y (send event get-y)]) + (let-values ([(editor-event-x editor-event-y) + (dc-location-to-editor-location dc-event-x dc-event-y)]) + (let ([pos (find-position editor-event-x editor-event-y #f on-it-b edge-close-b)]) + (cond + [(and (unbox on-it-b) + (not (<= (abs (unbox edge-close-b)) + (get-between-threshold)))) + (let ([snip (find-snip pos 'after-or-none)]) + (cond + [(and snip (is-a? snip image-map-snip%)) + (let ([bsnip-left (box 0)] + [bsnip-top (box 0)] + [bsnip-right (box 0)] + [bsnip-bot (box 0)]) + (get-snip-location snip bsnip-left bsnip-top #f) + (get-snip-location snip bsnip-right bsnip-bot #t) + (let ([snip-left (unbox bsnip-left)] + [snip-top (unbox bsnip-top)] + [snip-right (unbox bsnip-right)] + [snip-bot (unbox bsnip-bot)]) + (cond + [(and (<= snip-left editor-event-x snip-right) + (<= snip-top editor-event-y snip-bot)) + (let-values ([(x y) (editor-location-to-dc-location snip-left snip-top)]) + (send snip on-event (get-dc) x y snip-left snip-top event))] + [else (super on-event event)])))] + [else (super on-event event)]))] + [else (super on-event event)]))))) + + (super-new) + + ;; load url, but the user might break: + (with-handlers ([exn:break? void]) + ;(printf "url: ~a\n" (if (url? url) (url->string url) url)) ;; handy for debugging help desk + (reload progress)))) - [hp (make-control-bar-panel this)] - [control-bar? (is-a? hp area-container<%>)] - [back (and control-bar? - (make-object button% - (string-append "< " (string-constant rewind-in-browser-history)) - hp - (lambda (b ev) - (rewind))))] - [forw (and control-bar? - (make-object button% - (string-append (string-constant forward-in-browser-history) " >") - hp - (lambda (b ev) - (forward))))]) - - (define/private (home-callback) - (cond - [(or (url? init-page) - (string? init-page)) - - ; handle stopping when loading the home page - (with-handlers ([exn:break? - (lambda (x) (void))]) - (send c goto-url init-page #f) - (update-buttons))] - [else - (send c set-page init-page #t)])) - (field - [home (and control-bar? - (make-object button% (string-constant home) hp - (lambda (b ev) - (home-callback))))]) - - (define the-page #f) - (define/private (update-buttons/set-page page) - (unless init-page - (set! init-page page)) - (set! the-page page) - (update-buttons)) - (define/private (update-buttons) - (when control-bar? - (send home enable (or (url? init-page) (string? init-page))) - (send back enable (pair? past)) - (send forw enable (pair? future)) - - (send choice clear) - (for-each - (lambda (p) - (send choice append - (let ([s (send (car p) get-title)]) - (if s - (gui-utils:trim-string s 200) - (string-constant untitled))))) - (append (reverse future) - (if the-page (list the-page) null) - past)) - (let ([c (send choice get-number)]) - (unless (zero? c) - (send choice set-selection (length future)))))) - (field - [choice (and control-bar? - (make-object choice% #f null hp - (lambda (ch e) - (let* ([l (append (reverse past) - (list (send c current-page)) - future)] - [pos (- (send choice get-number) (send choice get-selection) 1)]) - (let loop ([l l][pre null][pos pos]) - (cond - [(zero? pos) - (set! past pre) - (set! future (cdr l)) - (go (car l))] - [else (loop (cdr l) - (cons (car l) pre) - (sub1 pos))]))))))] - [stop-callback void] - [stop-button - (and control-bar? - (new button% - (label (string-constant stop)) - (parent hp) - (callback (lambda (x y) (stop-callback)))))]) - (define/public (get-stop-button) stop-button) - (define/public (set-stop-callback bc) (set! stop-callback bc)) - (when stop-button (send stop-button enable #f)) - - (field - [info (and info-line? - (make-object info-canvas% this))] - [c (make-canvas this)]) - - ;; set-init-page : (union string url) -> void - [define/public set-init-page - (lambda (p) - (set! init-page p))] - [define/public goto-init-page - (lambda () - (home-callback))] - - [define/public on-navigate (lambda () (void))] - [define/public filter-notes (lambda (l) (apply string-append l))] - [define/public get-canvas (lambda () c)] - [define/public on-url-click (lambda (k url post-data) (k url post-data))] - - [define/public reload - (lambda () - (let ([c (get-canvas)]) - (and c - (let ([e (send c get-editor)]) - (and e - (send e reload))))))] - - (define/public (leaving-page page new-page) - (set! future null) - (when page - (set! past (cons page past))) - (when (> (length past) history-limit) - (set! past - (let loop ([l past]) - (if (null? (cdr l)) - null - (cons (car l) (loop (cdr l))))))) - (clear-info) - (update-buttons/set-page new-page) - (update-info new-page)) - (when control-bar? - (send choice stretchable-width #t) - (send hp stretchable-height #f)) - (update-buttons/set-page #f))) - - (define hyper-panel% (hyper-panel-mixin vertical-panel%)) - - (define hyper-frame<%> - (interface () - get-hyper-panel - get-hyper-panel%)) - - (define hyper-no-show-frame-mixin - (mixin (frame:status-line<%>) (hyper-frame<%>) - (field [p #f]) - (define/public get-hyper-panel% (lambda () hyper-panel%)) - (define/public get-hyper-panel (lambda () p)) - (inherit show get-area-container) - (super-instantiate ()) - (set! p (make-object (get-hyper-panel%) #f (get-area-container))))) - - (define hyper-frame-mixin - (compose - (mixin (hyper-frame<%> top-level-window<%>) () - (init start-url) - (inherit show get-hyper-panel) - (super-instantiate ()) - (show #t) - (send (send (get-hyper-panel) get-canvas) goto-url start-url #f)) - hyper-no-show-frame-mixin)) - - (define hyper-frame% (hyper-frame-mixin (frame:status-line-mixin frame:basic%))) - (define hyper-no-show-frame% (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%))) - - (define (editor->page e) (list e 0 0)) - (define (page->editor e) (car e)) - - (define (same-page? a b) - (eq? (car a) (car b))) - - (define (open-url file) - (make-object hyper-frame% file (string-constant browser) #f 500 450)) +;; build-html-error-message : exn -> string[html] +(define ((build-html-error-message str) exn) + (string-append + "Error Evaluating Scheme" + "" + "

    Error Evaluating Scheme Code

    " + (format "
    \n~a\n
    " str) + "

    " + (format "~a" + (regexp-replace* #rx"<" (regexp-replace* #rx">" (exn-message exn) "<") ">")) + "")) + +(define hyper-text% (hyper-text-mixin text:keymap%)) + +(define space-page-keymap (make-object keymap%)) +(add-text-keymap-functions space-page-keymap) +(send space-page-keymap map-function "space" "next-page") +(send space-page-keymap map-function "s:space" "previous-page") + +(define hyper-keymap (make-object keymap%)) +(send hyper-keymap add-function "rewind" + (lambda (txt evt) + (call-with-hyper-panel + txt + (lambda (panel) + (send panel rewind))))) +(send hyper-keymap add-function "forward" + (lambda (txt evt) + (call-with-hyper-panel + txt + (lambda (panel) + (send panel forward))))) +(send hyper-keymap add-function "do-wheel" + (lambda (txt evt) + ;; Redirect the event to the canvas, which should + ;; handle the event + (send (send txt get-canvas) on-char evt))) +(add-text-keymap-functions hyper-keymap) +(send hyper-keymap map-function "d:[" "rewind") +(send hyper-keymap map-function "a:[" "rewind") +(send hyper-keymap map-function "c:[" "rewind") +(send hyper-keymap map-function "d:left" "rewind") +(send hyper-keymap map-function "a:left" "rewind") +(send hyper-keymap map-function "c:left" "rewind") +(send hyper-keymap map-function "m:left" "rewind") +(send hyper-keymap map-function "d:]" "forward") +(send hyper-keymap map-function "a:]" "forward") +(send hyper-keymap map-function "c:]" "forward") +(send hyper-keymap map-function "d:right" "forward") +(send hyper-keymap map-function "a:right" "forward") +(send hyper-keymap map-function "c:right" "forward") +(send hyper-keymap map-function "m:right" "forward") +(send hyper-keymap map-function "wheelup" "do-wheel") +(send hyper-keymap map-function "pageup" "previous-page") +(send hyper-keymap map-function "wheeldown" "do-wheel") +(send hyper-keymap map-function "pagedown" "next-page") + +;; call-with-hyper-panel : object ((is-a?/c hyper-panel<%>) -> void) -> void +(define (call-with-hyper-panel text f) + (when (is-a? text hyper-text<%>) + (let ([canvas (send text get-canvas)]) + (when canvas + (let ([tlw (send canvas get-top-level-window)]) + (when (is-a? tlw hyper-frame<%>) + (f (send tlw get-hyper-panel)))))))) + +;; path-below? : string[normalized-path] string[normalized-path] -> boolean +;; returns #t if subpath points to a place below top +(define (path-below? top longer) + (let loop ([top (explode-path top)] + [longer (explode-path longer)]) + (cond + [(null? top) #t] + [(null? longer) #f] + [(equal? (car top) (car longer)) + (loop (cdr top) (cdr longer))] + [else #f]))) + +(keymap:add-to-right-button-menu/before + (let ([old (keymap:add-to-right-button-menu/before)]) + (lambda (menu editor event) + (when (is-a? editor hyper-text<%>) + (let* ([panel (let ([canvas (send editor get-canvas)]) + (and canvas + (send (send canvas get-top-level-window) get-hyper-panel)))] + [back + (instantiate menu-item% () + (label (string-append "< " (string-constant rewind-in-browser-history))) + (parent menu) + (callback + (lambda (_1 _2) + (when panel + (send panel rewind)))))] + [forward + (instantiate menu-item% () + (label (string-append (string-constant forward-in-browser-history) " >")) + (parent menu) + (callback + (lambda (_1 _2) + (when panel + (send panel forward)))))]) + (send back enable (send panel can-rewind?)) + (send forward enable (send panel can-forward?)) + (instantiate separator-menu-item% () + (parent menu)))) + (old menu editor event)))) + +(define hyper-canvas-mixin + (mixin ((class->interface editor-canvas%)) () + (inherit get-editor set-editor refresh get-parent get-top-level-window) + + (define/public (get-editor%) hyper-text%) + + (define/public (current-page) + (let ([e (get-editor)]) + (and e + (let ([sbox (box 0)] + [ebox (box 0)]) + (send e get-visible-position-range sbox ebox) + (list e (unbox sbox) (unbox ebox)))))) + (define/public (on-url-click k url post-data) + (send (get-parent) on-url-click k url post-data)) + (define/public goto-url + (lambda (in-url relative [progress void] [post-data #f]) + (let ([tlw (get-top-level-window)]) + (when (and tlw + (is-a? tlw hyper-frame<%>)) + (let* ([pre-url (cond + [(url? in-url) in-url] + [(port? in-url) in-url] + [(string? in-url) + (if relative + (combine-url/relative relative in-url) + (string->url in-url))] + [else (error 'goto-url "unknown url ~e\n" in-url)])] + [killable-cust (make-custodian)] + [hyper-panel (send tlw get-hyper-panel)] + [result + (let ([e-now (get-editor)]) + (cond + [(and e-now + (not post-data) + (same-page-url? pre-url (send e-now get-url))) + (progress #t) + (cons e-now pre-url)] + [else + (send hyper-panel set-stop-callback + (lambda () + (custodian-shutdown-all killable-cust))) + (send hyper-panel enable-browsing #f) + (begin0 + (make-editor/setup-kill killable-cust + (get-editor%) + tlw + pre-url + progress + post-data + (lambda (x) (remap-url x))) + (send hyper-panel set-stop-callback void) + (send hyper-panel enable-browsing #t))]))]) + (cond + [(pair? result) + (let* ([e (car result)] + [url (cdr result)] + [tag-pos (send e find-tag (and (url? url) (url-fragment url)))]) + (unless (and tag-pos (positive? tag-pos)) + (send e hide-caret #t)) + (set-page (list e (or tag-pos 0) (send e last-position)) #t) + (when tag-pos (send e set-position tag-pos)))] + [(exn? result) + (message-box (string-constant drscheme) + (exn-message result) + tlw)] + [else (void)])))))) + + ;; remap-url : url? -> (union #f url?) + ;; this method is intended to be overridden so that derived classes can change + ;; the behavior of the browser. Calls to this method may be killed. + (define/public (remap-url url) + url) + + (define/public (after-set-page) (void)) + (define/public (set-page page notify?) + (let ([e (car page)] + [spos (cadr page)] + [epos (caddr page)] + [curr (get-editor)] + [current (current-page)]) + ; Pre-size the editor to avoid visible reflow + (when curr + (let ([wbox (box 0)]) + (send curr get-view-size wbox (box 0)) + (when (send e auto-wrap) + (send e set-max-width (unbox wbox))))) + (send e begin-edit-sequence) + (when notify? + (send (get-parent) leaving-page current (list e 0 0))) + (set-editor e (and current (zero? (cadr current)) (zero? spos))) + (send e scroll-to-position spos #f epos 'start) + (send e end-edit-sequence) + (after-set-page) + (when (or (positive? spos) (not current) (positive? (cadr current))) + (refresh)))) + (super-new))) + +;; make-editor/setup-kill : custodian editor-class frame%-instance +;; url (boolean??? -> void) ??? (url -> (union port #f url)) +;; -> (union (cons editor (union #f url)) exn #f) +;; if cust is shutdown, the url will stop being loaded and a dummy editor is returned. +(define (make-editor/setup-kill cust html-editor% tlw init-url progress post-data remap-url) + (let* ([c (make-channel)] + [progs (make-channel)] + [sent-prog? #f] + [t (parameterize ([current-custodian cust]) + (thread + (lambda () + (with-handlers ([exn? (lambda (exn) + (channel-put c exn))]) + (channel-put + c + (make-editor/follow-redirections html-editor% + tlw + init-url + (lambda (v) + (channel-put progs v)) + post-data + remap-url))))))] + [ans #f]) + (let loop () + (yield + (choice-evt + (handle-evt c (lambda (x) (set! ans x))) + (handle-evt progs (lambda (v) + (set! sent-prog? #t) + (progress v) + (loop))) + (handle-evt (thread-dead-evt t) + (lambda (_) + (let ([t (new hyper-text% + (url #f) + (top-level-window #f) + (progress void))]) + (send t insert "Stopped.") + (set! ans (cons t #f)))))))) + (unless sent-prog? + (progress #f)) + ans)) + +;; make-editor/follow-redirections : editor-class frame%-instance +;; url (boolean??? -> void) ??? (url -> (union port #f url)) +;; -> (cons (union #f editor) (union #f url)) +;; builds an html editor using make-editor and follows any redictions, +;; but stops after 10 redirections (just in case there are too many +;; of these things, give the user a chance to stop) +(define (make-editor/follow-redirections html-editor% tlw init-url progress post-data remap-url) + (with-handlers ([(lambda (x) + (or (exn:file-saved-instead? x) + (exn:cancelled? x) + (exn:tcp-problem? x))) + values]) + (let loop ([n 10] + [unmapped-url init-url]) + (let ([url (if (url? unmapped-url) + (let ([rurl (remap-url unmapped-url)]) + (unless (or (url? rurl) + (input-port? rurl) + (not rurl)) + (error 'remap-url + "expected a url struct, an input-port, or #f, got ~e" + rurl)) + rurl) + unmapped-url)]) + (if url + (let ([html-editor (new html-editor% + [url url] + [top-level-window tlw] + [progress progress] + [post-data post-data])]) + (cond + [(zero? n) + (cons html-editor url)] + [(send html-editor get-redirection) + => + (lambda (new-url) (loop (- n 1) new-url))] + [else + (cons html-editor url)])) + #f))))) + +(define hyper-canvas% (hyper-canvas-mixin canvas:basic%)) + +(define info-canvas% + (class canvas% + (inherit min-client-height get-dc stretchable-height + get-parent enable refresh show) + (field + [text ""]) + [define/override on-paint + (lambda () + (let ([dc (get-dc)]) + (send dc clear) + (send dc draw-text text 4 2)))] + [define/public erase-info (lambda () + (unless (string=? text "") + (set! text "") + (let ([dc (get-dc)]) + (send dc clear))))] + [define/public set-info (lambda (t) + (set! text t) + (if (string=? t "") + (show #f) + (let ([dc (get-dc)]) + (send dc clear) + (show #t) + (refresh))))] + (super-instantiate ()) + (stretchable-height #f) + (enable #f) + (show #f) + (let ([font (make-object font% (send normal-control-font get-point-size) + 'default 'normal 'normal)] + [dc (get-dc)]) + (send dc set-font font) + (send dc set-text-foreground (make-object color% "FOREST GREEN")) + (let-values ([(w h d a) (send dc get-text-extent "X" font)]) + (min-client-height (+ 4 (inexact->exact (ceiling h)))))))) + +(define hyper-panel<%> + (interface () + current-page + rewind + forward + can-rewind? + can-forward? + get-canvas% + make-canvas + make-control-bar-panel + + set-init-page + goto-init-page + + on-navigate + filter-notes + get-canvas + on-url-click + reload + leaving-page + get-stop-button + set-stop-callback + + enable-browsing)) + +(define hyper-panel-mixin + (mixin (area-container<%>) (hyper-panel<%>) + (init info-line?) + (inherit reflow-container) + (super-new) + + (define browsing-on? #t) + (define/public (enable-browsing on?) + (set! browsing-on? on?) + (cond + [on? + (send stop-button enable #f) + (when choice (send choice enable #t)) + (update-buttons)] + [else + (send stop-button enable #t) + (when home (send home enable #f)) + (when forw (send forw enable #f)) + (when back (send back enable #f)) + (when choice (send choice enable #f))])) + + (define/private (clear-info) + (when info + (send info erase-info))) + (define/private (update-info page) + (when (and info page) + (let ([notes (send (page->editor page) get-document-notes)]) + (send info set-info + (filter-notes notes (send (page->editor page) get-url)))))) + (define/private (go page) + (clear-info) + (send c set-page page #f) + (update-info page) + (update-buttons/set-page page) + (on-navigate)) + + (define/public (current-page) (send c current-page)) + (define/public (rewind) + (unless (null? past) + (let ([page (car past)]) + (set! future (cons (send c current-page) future)) + (set! past (cdr past)) + (go page)))) + (define/public (forward) + (unless (null? future) + (let ([page (car future)]) + (set! past (cons (send c current-page) past)) + (set! future (cdr future)) + (go page)))) + (define/public (can-forward?) (and browsing-on? (not (null? future)))) + (define/public (can-rewind?) (and browsing-on? (not (null? past)))) + [define/public get-canvas% (lambda () hyper-canvas%)] + [define/public make-canvas (lambda (f) (make-object (get-canvas%) f))] + [define/public make-control-bar-panel (lambda (f) (make-object horizontal-panel% f))] + (field + [past null] + [future null] + + + ;; (union #f -- no init page + ;; string -- delayed init page + ;; url -- delayed init page + ;; (list editor number numer)) -- forced init page + [init-page #f] + + [hp (make-control-bar-panel this)] + [control-bar? (is-a? hp area-container<%>)] + [back (and control-bar? + (make-object button% + (string-append "< " (string-constant rewind-in-browser-history)) + hp + (lambda (b ev) + (rewind))))] + [forw (and control-bar? + (make-object button% + (string-append (string-constant forward-in-browser-history) " >") + hp + (lambda (b ev) + (forward))))]) + + (define/private (home-callback) + (cond + [(or (url? init-page) + (string? init-page)) + + ; handle stopping when loading the home page + (with-handlers ([exn:break? + (lambda (x) (void))]) + (send c goto-url init-page #f) + (update-buttons))] + [else + (send c set-page init-page #t)])) + (field + [home (and control-bar? + (make-object button% (string-constant home) hp + (lambda (b ev) + (home-callback))))]) + + (define the-page #f) + (define/private (update-buttons/set-page page) + (unless init-page + (set! init-page page)) + (set! the-page page) + (update-buttons)) + (define/private (update-buttons) + (when control-bar? + (send home enable (or (url? init-page) (string? init-page))) + (send back enable (pair? past)) + (send forw enable (pair? future)) + + (send choice clear) + (for-each + (lambda (p) + (send choice append + (let ([s (send (car p) get-title)]) + (if s + (gui-utils:trim-string s 200) + (string-constant untitled))))) + (append (reverse future) + (if the-page (list the-page) null) + past)) + (let ([c (send choice get-number)]) + (unless (zero? c) + (send choice set-selection (length future)))))) + (field + [choice (and control-bar? + (make-object choice% #f null hp + (lambda (ch e) + (let* ([l (append (reverse past) + (list (send c current-page)) + future)] + [pos (- (send choice get-number) (send choice get-selection) 1)]) + (let loop ([l l][pre null][pos pos]) + (cond + [(zero? pos) + (set! past pre) + (set! future (cdr l)) + (go (car l))] + [else (loop (cdr l) + (cons (car l) pre) + (sub1 pos))]))))))] + [stop-callback void] + [stop-button + (and control-bar? + (new button% + (label (string-constant stop)) + (parent hp) + (callback (lambda (x y) (stop-callback)))))]) + (define/public (get-stop-button) stop-button) + (define/public (set-stop-callback bc) (set! stop-callback bc)) + (when stop-button (send stop-button enable #f)) + + (field + [info (and info-line? + (make-object info-canvas% this))] + [c (make-canvas this)]) + + ;; set-init-page : (union string url) -> void + [define/public set-init-page + (lambda (p) + (set! init-page p))] + [define/public goto-init-page + (lambda () + (home-callback))] + + [define/public on-navigate (lambda () (void))] + [define/public filter-notes (lambda (l) (apply string-append l))] + [define/public get-canvas (lambda () c)] + [define/public on-url-click (lambda (k url post-data) (k url post-data))] + + [define/public reload + (lambda () + (let ([c (get-canvas)]) + (and c + (let ([e (send c get-editor)]) + (and e + (send e reload))))))] + + (define/public (leaving-page page new-page) + (set! future null) + (when page + (set! past (cons page past))) + (when (> (length past) history-limit) + (set! past + (let loop ([l past]) + (if (null? (cdr l)) + null + (cons (car l) (loop (cdr l))))))) + (clear-info) + (update-buttons/set-page new-page) + (update-info new-page)) + (when control-bar? + (send choice stretchable-width #t) + (send hp stretchable-height #f)) + (update-buttons/set-page #f))) + +(define hyper-panel% (hyper-panel-mixin vertical-panel%)) + +(define hyper-frame<%> + (interface () + get-hyper-panel + get-hyper-panel%)) + +(define hyper-no-show-frame-mixin + (mixin (frame:status-line<%>) (hyper-frame<%>) + (field [p #f]) + (define/public get-hyper-panel% (lambda () hyper-panel%)) + (define/public get-hyper-panel (lambda () p)) + (inherit show get-area-container) + (super-instantiate ()) + (set! p (make-object (get-hyper-panel%) #f (get-area-container))))) + +(define hyper-frame-mixin + (let ([m (mixin (hyper-frame<%> top-level-window<%>) () + (init start-url) + (inherit show get-hyper-panel) + (super-instantiate ()) + (show #t) + (send (send (get-hyper-panel) get-canvas) goto-url start-url #f))]) + (lambda (%) + (hyper-no-show-frame-mixin (m %))))) + +(define hyper-frame% (hyper-frame-mixin (frame:status-line-mixin frame:basic%))) +(define hyper-no-show-frame% (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%))) + +(define (editor->page e) (list e 0 0)) +(define (page->editor e) (car e)) + +(define (same-page? a b) + (eq? (car a) (car b))) + +(define (open-url file) + (make-object hyper-frame% file (string-constant browser) #f 500 450)) diff --git a/collects/browser/private/sig.ss b/collects/browser/private/sig.ss index 623b4aa358..aa09d07957 100644 --- a/collects/browser/private/sig.ss +++ b/collects/browser/private/sig.ss @@ -1,5 +1,5 @@ -(module sig mzscheme - (require (lib "unit.ss")) +(module sig scheme/base + (require scheme/unit) (provide relative-btree^ bullet-export^ diff --git a/collects/drscheme/private/app.ss b/collects/drscheme/private/app.ss index 00957f6e70..4825c36a76 100644 --- a/collects/drscheme/private/app.ss +++ b/collects/drscheme/private/app.ss @@ -2,7 +2,7 @@ #lang scheme/unit (require (lib "class.ss") (lib "list.ss") - (lib "file.ss") + scheme/file (lib "string-constant.ss" "string-constants") (lib "mred.ss" "mred") (lib "framework.ss" "framework") diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 5cad50c0ea..925c1b518a 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -1,6 +1,6 @@ -(module drsig mzscheme - (require (lib "unit.ss")) +(module drsig scheme/base + (require scheme/unit) (provide drscheme:eval^ drscheme:debug^ @@ -33,8 +33,7 @@ get-modes add-initial-modes (struct mode (name surrogate repl-submit matches-language) - -setters - -constructor))) + #:omit-constructor))) (define-signature drscheme:font^ (setup-preferences)) @@ -93,7 +92,7 @@ (define-signature drscheme:language-configuration^ (add-language get-languages - (struct language-settings (language settings) -setters) + (struct language-settings (language settings)) get-settings-preferences-symbol language-dialog fill-language-dialog)) @@ -216,16 +215,15 @@ create-executable-gui put-executable - ;(struct loc (source position line column span) -setters) + ;(struct loc (source position line column span)) - (struct text/pos (text start end) -setters) + (struct text/pos (text start end)) (struct simple-settings (case-sensitive printing-style fraction-style show-sharing insert-newlines - annotations) - -setters) + annotations)) simple-settings->vector simple-module-based-language-config-panel diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss index 6972d18f56..ebd87abbf7 100644 --- a/collects/drscheme/private/frame.ss +++ b/collects/drscheme/private/frame.ss @@ -2,7 +2,6 @@ #lang scheme/unit (require (lib "name-message.ss" "mrlib") (lib "string-constant.ss" "string-constants") - (lib "unit.ss") (lib "match.ss") (lib "class.ss") (lib "string.ss") @@ -14,8 +13,7 @@ (lib "head.ss" "net") (lib "plt-installer.ss" "setup") (lib "bug-report.ss" "help") - (prefix mzlib:file: (lib "file.ss")) (lib "file.ss") - (prefix mzlib:list: (lib "list.ss"))) + scheme/file) (import [prefix drscheme:unit: drscheme:unit^] [prefix drscheme:app: drscheme:app^] @@ -123,7 +121,7 @@ (filter (λ (binding) (not (bound-by-menu? binding menu-names))) bindings))] [structured-list - (mzlib:list:sort + (sort w/menus (λ (x y) (string-ci<=? (cadr x) (cadr y))))]) (show-keybindings-to-user structured-list this)) @@ -500,8 +498,8 @@ (λ (a b) (string-ci<=? (cadr a) (cadr b)))]) (send lb set (if by-key? - (map format-binding/key (mzlib:list:sort bindings predicate/key)) - (map format-binding/name (mzlib:list:sort bindings predicate/name))))))]) + (map format-binding/key (sort bindings predicate/key)) + (map format-binding/name (sort bindings predicate/name))))))]) (send bp stretchable-height #f) (send bp set-alignment 'center 'center) (send bp2 stretchable-height #f) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 0195d69631..a33b0291b5 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -11,7 +11,7 @@ (lib "etc.ss") (lib "struct.ss") (lib "class.ss") - (lib "file.ss") + scheme/file (lib "list.ss") (lib "embed.ss" "compiler") (lib "launcher.ss" "launcher") @@ -1131,7 +1131,7 @@ (let ([s (reader (object-name port) port)]) (if (syntax? s) (with-syntax ([s s] - [t (namespace-syntax-introduce (datum->syntax-object #f '#%top-interaction))]) + [t (namespace-syntax-introduce (datum->syntax #f '#%top-interaction))]) (syntax (t . s))) s)))) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 577e035d01..806adc5dcc 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -7,11 +7,11 @@ (lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "class.ss") - (prefix pretty-print: (lib "pretty.ss")) - (prefix print-convert: (lib "pconvert.ss")) + (prefix-in pretty-print: (lib "pretty.ss")) + (prefix-in print-convert: (lib "pconvert.ss")) (lib "include.ss") (lib "list.ss") - (lib "file.ss") + scheme/file (lib "external.ss" "browser") (lib "plt-installer.ss" "setup")) diff --git a/collects/drscheme/private/multi-file-search.ss b/collects/drscheme/private/multi-file-search.ss index 0f4e0fd698..8b12fc944b 100644 --- a/collects/drscheme/private/multi-file-search.ss +++ b/collects/drscheme/private/multi-file-search.ss @@ -3,7 +3,7 @@ (require (lib "framework.ss" "framework") (lib "class.ss") (lib "mred.ss" "mred") - (lib "file.ss") + scheme/file (lib "thread.ss") (lib "async-channel.ss") (lib "string-constant.ss" "string-constants") diff --git a/collects/framework/private/autosave.ss b/collects/framework/private/autosave.ss index 1de497d844..b7ca3288fc 100644 --- a/collects/framework/private/autosave.ss +++ b/collects/framework/private/autosave.ss @@ -2,7 +2,7 @@ #lang scheme/unit (require (lib "class.ss") - (lib "file.ss") + scheme/file "sig.ss" "../gui-utils.ss" "../preferences.ss" diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 509e8afedf..aad7d6b94f 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -7,7 +7,7 @@ "../gui-utils.ss" (lib "etc.ss") (lib "mred-sig.ss" "mred") - (lib "file.ss")) + scheme/file) (import mred^ [prefix autosave: framework:autosave^] diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss index 1ed3aedf09..801fc8184d 100644 --- a/collects/framework/private/finder.ss +++ b/collects/framework/private/finder.ss @@ -5,7 +5,7 @@ "../preferences.ss" (lib "mred-sig.ss" "mred") (lib "string.ss") - (lib "file.ss") + scheme/file (lib "etc.ss")) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 3fd0da0548..4763a0f744 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -8,7 +8,7 @@ "bday.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") - (lib "file.ss") + scheme/file (lib "etc.ss")) (import mred^ @@ -310,7 +310,7 @@ (define-struct status-line (id count)) ;; status-line-msg : (make-status-line-msg (is-a?/c message%) (union symbol #f)) - (define-struct status-line-msg (message id)) + (define-struct status-line-msg (message [id #:mutable])) (define status-line-mixin (mixin (basic<%>) (status-line<%>) diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index bcf5ea7070..1d0adab4f9 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -7,7 +7,7 @@ "../gui-utils.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") - (lib "file.ss")) + scheme/file) (import mred^ [prefix application: framework:application^] diff --git a/collects/framework/private/handler.ss b/collects/framework/private/handler.ss index f9d1cc1bc4..c4eed5add8 100644 --- a/collects/framework/private/handler.ss +++ b/collects/framework/private/handler.ss @@ -7,7 +7,7 @@ "../preferences.ss" "../gui-utils.ss" (lib "mred-sig.ss" "mred") - (lib "file.ss") + scheme/file (lib "string-constant.ss" "string-constants")) diff --git a/collects/framework/private/icon.ss b/collects/framework/private/icon.ss index 718f8e5fce..ee2f62bd80 100644 --- a/collects/framework/private/icon.ss +++ b/collects/framework/private/icon.ss @@ -1,5 +1,6 @@ #lang scheme/unit - (require (lib "class.ss") + (require (for-syntax scheme/base) + (lib "class.ss") (lib "include-bitmap.ss" "mrlib") "bday.ss" "sig.ss" diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index 4d0a7ec717..d93b097b3b 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -511,7 +511,7 @@ (λ (edit event) (let ([sel-start (send edit get-start-position)] [sel-end (send edit get-end-position)]) - (if (= sel-start sel-end) + (when (= sel-start sel-end) (send* edit (insert #\newline) (set-position sel-start)))))] @@ -729,7 +729,7 @@ (get-text-from-user (string-constant goto-position) (string-constant goto-position))))]) - (if (string? num-str) + (when (string? num-str) (let ([pos (string->number num-str)]) (when pos (send edit set-position (sub1 pos)))))) diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss index 8d8e4dbda7..674fa32de6 100644 --- a/collects/framework/private/panel.ss +++ b/collects/framework/private/panel.ss @@ -164,7 +164,7 @@ (define-struct gap (before before-dim before-percentage after after-dim after-percentage)) ;; type percentage : (make-percentage number) - (define-struct percentage (%)) + (define-struct percentage (%) #:mutable) (define dragable<%> (interface (window<%> area-container<%>) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 1a8a959560..2c65d98227 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -30,7 +30,7 @@ the state transitions / contracts are: (require (lib "string-constant.ss" "string-constants") (lib "class.ss") - (lib "file.ss") + scheme/file "sig.ss" "../gui-utils.ss" "../preferences.ss" @@ -117,7 +117,7 @@ the state transitions / contracts are: ;; (make-ppanel-interior string (union #f panel) (listof panel-tree))) (define-struct ppanel (name panel)) (define-struct (ppanel-leaf ppanel) (maker)) - (define-struct (ppanel-interior ppanel) (children)) + (define-struct (ppanel-interior ppanel) (children) #:mutable) ;; ppanels : (listof ppanel-tree) (define ppanels null) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index c2a6457dbe..15b5a506da 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -75,7 +75,7 @@ (send text last-position) (send text last-position))) saved-snips) - (datum->syntax-object + (datum->syntax #f (read (open-input-text-editor text)) (list file line col pos 1)))) @@ -551,10 +551,10 @@ [get-proc (λ () (let ([id-end (get-forward-sexp contains)]) - (if (and id-end (> id-end contains)) - (let* ([text (get-text contains id-end)]) - (or (get-keyword-type text tabify-prefs) - 'other)))))] + (and (and id-end (> id-end contains)) + (let* ([text (get-text contains id-end)]) + (or (get-keyword-type text tabify-prefs) + 'other)))))] [procedure-indent (λ () (case (get-proc) @@ -715,7 +715,7 @@ (let* ([first-para (position-paragraph start-pos)] [last-para (calc-last-para end-pos)]) (let para-loop ([curr-para first-para]) - (if (<= curr-para last-para) + (when (<= curr-para last-para) (let ([first-on-para (paragraph-start-position curr-para)]) (insert #\; first-on-para) (para-loop (add1 curr-para)))))) @@ -964,8 +964,8 @@ [first-char (get-character pos)] [paren? (or (char=? first-char #\( ) (char=? first-char #\[ ))] - [closer (if paren? - (get-forward-sexp pos))]) + [closer (and paren? + (get-forward-sexp pos))]) (if (and paren? closer) (begin (begin-edit-sequence) (delete pos (add1 pos)) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 1c112d9b2b..e77818c3bd 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -1,7 +1,7 @@ -(module sig mzscheme - (require (lib "unit.ss")) +(module sig scheme/base + (require scheme/unit) - (provide (prefix-all-defined-except framework: framework^) + (provide (prefix-out framework: (except-out (all-defined-out) framework^)) framework^) (define-signature number-snip-class^ diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 98b229939a..f9eee04569 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -18,7 +18,7 @@ WARNING: printf is rebound in the body of the unit to always (lib "etc.ss") (lib "dirs.ss" "setup") (lib "string.ss") - (prefix srfi1: (lib "1.ss" "srfi"))) + (prefix-in srfi1: (lib "1.ss" "srfi"))) (import mred^ [prefix icon: framework:icon^] @@ -954,7 +954,7 @@ WARNING: printf is rebound in the body of the unit to always get-box-input-editor-snip% get-box-input-text%)) - (define-struct peeker (bytes skip-count pe resp-chan nack polling?) (make-inspector)) + (define-struct peeker (bytes skip-count pe resp-chan nack polling?) #:inspector (make-inspector)) (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) (define msec-timeout 500) @@ -1989,7 +1989,7 @@ WARNING: printf is rebound in the body of the unit to always ;; ;; queues ;; - (define-struct queue (front back count)) + (define-struct queue (front back count) #:mutable) (define (empty-queue) (make-queue '() '() 0)) (define (enqueue e q) (make-queue (cons e (queue-front q)) diff --git a/collects/frtime/graphics-posn-less-unit.ss b/collects/frtime/graphics-posn-less-unit.ss index 5a940c1534..572b09973d 100644 --- a/collects/frtime/graphics-posn-less-unit.ss +++ b/collects/frtime/graphics-posn-less-unit.ss @@ -122,7 +122,7 @@ |# [on-char (lambda (key-event) - (if key-listener + (when key-listener (send-event key-listener (make-sixkey diff --git a/collects/graphics/turtle-unit.ss b/collects/graphics/turtle-unit.ss index c478f2af93..9623eabfbe 100644 --- a/collects/graphics/turtle-unit.ss +++ b/collects/graphics/turtle-unit.ss @@ -1,466 +1,466 @@ #lang scheme/unit - (require (lib "mred-sig.ss" "mred") - (lib "class.ss") - (lib "class100.ss") - (lib "list.ss") - (lib "etc.ss") - "turtle-sig.ss") - - (import [prefix mred: mred^]) - (export turtle^) - (init-depend mred^) +(require (lib "mred-sig.ss" "mred") + (lib "class.ss") + (lib "class100.ss") + (lib "list.ss") + (lib "etc.ss") + "turtle-sig.ss") + +(import [prefix mred: mred^]) +(export turtle^) +(init-depend mred^) + +(define turtles:window #f) +(define turtles:shown? #f) + +(define pi 3.141592653589793) +(define pi/2 (/ pi 2)) + +(define icon-pen (send mred:the-pen-list find-or-create-pen "SALMON" 1 'xor)) +(define icon-brush (send mred:the-brush-list find-or-create-brush "SALMON" 'xor)) +(define blank-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent)) +(define w-pen (send mred:the-pen-list find-or-create-pen "white" 1 'solid)) +(define b-pen (send mred:the-pen-list find-or-create-pen "black" 1 'solid)) + +(define show-turtle-icons? #t) + +;; turtle-style : (union 'triangle 'line 'empty) +(define turtle-style 'triangle) + +(define plot-window% + (class100 mred:frame% (name width height) - (define turtles:window #f) - (define turtles:shown? #f) - - (define pi 3.141592653589793) - (define pi/2 (/ pi 2)) - - (define icon-pen (send mred:the-pen-list find-or-create-pen "SALMON" 1 'xor)) - (define icon-brush (send mred:the-brush-list find-or-create-brush "SALMON" 'xor)) - (define blank-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent)) - (define w-pen (send mred:the-pen-list find-or-create-pen "white" 1 'solid)) - (define b-pen (send mred:the-pen-list find-or-create-pen "black" 1 'solid)) - - (define show-turtle-icons? #t) - - ;; turtle-style : (union 'triangle 'line 'empty) - (define turtle-style 'triangle) - - (define plot-window% - (class100 mred:frame% (name width height) - - (private-field - [bitmap (make-object mred:bitmap% width height #t)]) - - (inherit show) - (private-field - [memory-dc (make-object mred:bitmap-dc%)] - [pl (make-object mred:point% 0 0)] - [pr (make-object mred:point% 0 0)] - [ph (make-object mred:point% 0 0)] - [points (list pl pr ph)]) - (public - [get-canvas - (lambda () - canvas)] - [flip-icons - (lambda () - (case turtle-style - [(triangle line) - (flatten (lambda (x) x)) - (let* ([dc (send canvas get-dc)] - [proc - (if (eq? turtle-style 'line) - (lambda (turtle) - (let ([x (turtle-x turtle)] - [y (turtle-y turtle)] - [theta (turtle-angle turtle)] - [size 2]) - (send dc draw-line - x y - (+ x (* size (cos theta))) - (+ y (* size (sin theta)))))) - (lambda (turtle) - (let* ([x (turtle-x turtle)] - [y (turtle-y turtle)] - [theta (turtle-angle turtle)] - [long-size 20] - [short-size 7] - [l-theta (+ theta pi/2)] - [r-theta (- theta pi/2)]) - (send ph set-x (+ x (* long-size (cos theta)))) - (send ph set-y (+ y (* long-size (sin theta)))) - (send pl set-x (+ x (* short-size (cos l-theta)))) - (send pl set-y (+ y (* short-size (sin l-theta)))) - (send pr set-x (+ x (* short-size (cos r-theta)))) - (send pr set-y (+ y (* short-size (sin r-theta)))) - (send dc draw-polygon points))))]) + (private-field + [bitmap (make-object mred:bitmap% width height #t)]) + + (inherit show) + (private-field + [memory-dc (make-object mred:bitmap-dc%)] + [pl (make-object mred:point% 0 0)] + [pr (make-object mred:point% 0 0)] + [ph (make-object mred:point% 0 0)] + [points (list pl pr ph)]) + (public + [get-canvas + (lambda () + canvas)] + [flip-icons + (lambda () + (case turtle-style + [(triangle line) + (flatten (lambda (x) x)) + (let* ([dc (send canvas get-dc)] + [proc (if (eq? turtle-style 'line) - (send dc set-pen icon-pen) - (begin - (send dc set-pen blank-pen) - (send dc set-brush icon-brush))) - (for-each proc turtles-state) - (send dc set-pen b-pen))] + (lambda (turtle) + (let ([x (turtle-x turtle)] + [y (turtle-y turtle)] + [theta (turtle-angle turtle)] + [size 2]) + (send dc draw-line + x y + (+ x (* size (cos theta))) + (+ y (* size (sin theta)))))) + (lambda (turtle) + (let* ([x (turtle-x turtle)] + [y (turtle-y turtle)] + [theta (turtle-angle turtle)] + [long-size 20] + [short-size 7] + [l-theta (+ theta pi/2)] + [r-theta (- theta pi/2)]) + (send ph set-x (+ x (* long-size (cos theta)))) + (send ph set-y (+ y (* long-size (sin theta)))) + (send pl set-x (+ x (* short-size (cos l-theta)))) + (send pl set-y (+ y (* short-size (sin l-theta)))) + (send pr set-x (+ x (* short-size (cos r-theta)))) + (send pr set-y (+ y (* short-size (sin r-theta)))) + (send dc draw-polygon points))))]) + (if (eq? turtle-style 'line) + (send dc set-pen icon-pen) + (begin + (send dc set-pen blank-pen) + (send dc set-brush icon-brush))) + (for-each proc turtles-state) + (send dc set-pen b-pen))] + [else + (void)]))] + [clear + (lambda () + (send memory-dc clear) + (send canvas on-paint))]) + (sequence + (send memory-dc set-bitmap bitmap) + (send memory-dc clear) + (super-init name #f width height)) + + (public + [on-menu-command (lambda (op) (turtles #f))]) + (private-field + [menu-bar (make-object mred:menu-bar% this)] + [file-menu (make-object mred:menu% "File" menu-bar)]) + (sequence + (make-object mred:menu-item% + "Print" + file-menu + (lambda (_1 _2) + (print))) + (make-object mred:menu-item% + "Close" + file-menu + (lambda (_1 _2) + (turtles #f)))) + + (public + [save-turtle-bitmap + (lambda (fn type) + (send bitmap save-file fn type))]) + + (private-field + [canvas% + (class100 mred:canvas% args + (inherit get-dc) + (override + [on-paint + (lambda () + (let ([dc (get-dc)]) + (send dc clear) + (send dc draw-bitmap (send memory-dc get-bitmap) 0 0) + (flip-icons)))]) + (sequence (apply super-init args)))] + [canvas (make-object canvas% this)] + [dc (send canvas get-dc)]) + + (public + [wipe-line (lambda (a b c d) + (send memory-dc set-pen w-pen) + (send dc set-pen w-pen) + (send memory-dc draw-line a b c d) + (send dc draw-line a b c d) + (send memory-dc set-pen b-pen) + (send dc set-pen b-pen))] + [draw-line (lambda (a b c d) + (send memory-dc draw-line a b c d) + (send dc draw-line a b c d))]) + (sequence + (send canvas min-width width) + (send canvas min-height height) + (send this clear)))) + +(define turtle-window-size + (let-values ([(w h) (mred:get-display-size)] + [(user/client-offset) 65] + [(default-size) 800]) + (min default-size + (- w user/client-offset) + (- h user/client-offset)))) + +(define-struct turtle (x y angle)) + ; x : int + ; y: int + ; angle : int + +(define-struct cached (turtles cache)) + ; turtles : (list-of turtle) + ; cache : turtle -> turtle + +(define-struct tree (children)) + ; children : (list-of cached) + +(define clear-turtle (make-turtle (/ turtle-window-size 2) + (/ turtle-window-size 2) 0)) + +;; turtles-state is either a +;; - (list-of turtle) or +;; - tree +(define turtles-state (list clear-turtle)) + +;; the cache contains a turtle-offset, which is represented +;; by a turtle -- but it is a delta not an absolute. +(define empty-cache (make-turtle 0 0 0)) +(define turtles-cache empty-cache) + +(define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles)."))) +(define inner-line init-error) +(define inner-wipe-line init-error) +(define inner-clear-window init-error) +(define inner-flip-icons init-error) +(define inner-save-turtle-bitmap init-error) + +(define line + (lambda (a b c d) + (set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing)) + (inner-line a b c d))) +(define do-wipe-line + (lambda (a b c d) + (set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing)) + (inner-wipe-line a b c d))) +(define (flip-icons) (inner-flip-icons)) + +(define clear-window (lambda () (inner-clear-window))) +(define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y))) + +(define turtles + (case-lambda + [() (turtles #t)] + [(x) + (set! turtles:shown? x) + (unless turtles:window + (set! turtles:window + (make-object plot-window% + "Turtles" + turtle-window-size + turtle-window-size)) + (set! inner-line (lambda x (send turtles:window draw-line . x))) + (set! inner-wipe-line (lambda x (send turtles:window wipe-line . x))) + (set! inner-clear-window (lambda x (send turtles:window clear . x))) + (set! inner-save-turtle-bitmap (lambda x (send turtles:window save-turtle-bitmap . x))) + (set! flip-icons (lambda x (send turtles:window flip-icons . x)))) + (send turtles:window show x) + (send turtles:window get-canvas)])) + +(define clear + (lambda () + (set! turtles-cache empty-cache) + (set! turtles-state (list clear-turtle)) + (set! lines-in-drawing null) + (clear-window))) + +;; cache elements: +(define-struct c-forward (distance)) +(define-struct c-turn (angle)) +(define-struct c-draw (distance)) +(define-struct c-offset (x y)) + +;; combines a cache-element and a turtle-offset. +;; turtle-offsets are represented as turtles, +;; however they are deltas, not absolutes. +(define combine + (lambda (entry cache) + (cond + [(c-forward? entry) + (let* ([n (c-forward-distance entry)] + [angle (turtle-angle cache)] + [x (turtle-x cache)] + [y (turtle-y cache)] + [newx (+ x (* n (cos angle)))] + [newy (+ y (* n (sin angle)))]) + (make-turtle newx newy angle))] + [(c-offset? entry) + (let* ([tx (turtle-x cache)] + [ty (turtle-y cache)] + [newx (+ tx (c-offset-x entry))] + [newy (+ ty (c-offset-y entry))]) + (make-turtle newx newy + (turtle-angle cache)))] + [(c-turn? entry) + (make-turtle (turtle-x cache) + (turtle-y cache) + (- (turtle-angle cache) + (c-turn-angle entry)))] + [else + (error 'turtles-cache "illegal entry in cache: ~a" entry)]))) + +;; this applies an offset to a turtle. +;; an offset is a turtle, representing what would happen +;; if the turtle had started at zero. +(define apply-cache + (lambda (offset) + (let ([x (turtle-x offset)] + [y (turtle-y offset)] + [offset-angle (turtle-angle offset)]) + (lambda (turtle) + (let* ([angle (turtle-angle turtle)]) + (let* ([c (cos angle)] + [s (sin angle)] + [rx (- (* x c) (* y s))] + [ry (+ (* y c) (* x s))]) + (make-turtle (+ rx (turtle-x turtle)) + (+ ry (turtle-y turtle)) + (+ offset-angle angle)))))))) + +(define flatten + (lambda (at-end) + (letrec ([walk-turtles + (lambda (turtles cache list) + (cond + [(tree? turtles) + (let ([children (tree-children turtles)] + [ac (apply-cache cache)]) + (foldl (lambda (child list) + (walk-turtles (cached-turtles child) + (ac (cached-cache child)) + list)) + list + children))] [else - (void)]))] - [clear - (lambda () - (send memory-dc clear) - (send canvas on-paint))]) - (sequence - (send memory-dc set-bitmap bitmap) - (send memory-dc clear) - (super-init name #f width height)) - - (public - [on-menu-command (lambda (op) (turtles #f))]) - (private-field - [menu-bar (make-object mred:menu-bar% this)] - [file-menu (make-object mred:menu% "File" menu-bar)]) - (sequence - (make-object mred:menu-item% - "Print" - file-menu - (lambda (_1 _2) - (print))) - (make-object mred:menu-item% - "Close" - file-menu - (lambda (_1 _2) - (turtles #f)))) - - (public - [save-turtle-bitmap - (lambda (fn type) - (send bitmap save-file fn type))]) - - (private-field - [canvas% - (class100 mred:canvas% args - (inherit get-dc) - (override - [on-paint - (lambda () - (let ([dc (get-dc)]) - (send dc clear) - (send dc draw-bitmap (send memory-dc get-bitmap) 0 0) - (flip-icons)))]) - (sequence (apply super-init args)))] - [canvas (make-object canvas% this)] - [dc (send canvas get-dc)]) - - (public - [wipe-line (lambda (a b c d) - (send memory-dc set-pen w-pen) - (send dc set-pen w-pen) - (send memory-dc draw-line a b c d) - (send dc draw-line a b c d) - (send memory-dc set-pen b-pen) - (send dc set-pen b-pen))] - [draw-line (lambda (a b c d) - (send memory-dc draw-line a b c d) - (send dc draw-line a b c d))]) - (sequence - (send canvas min-width width) - (send canvas min-height height) - (send this clear)))) - - (define turtle-window-size - (let-values ([(w h) (mred:get-display-size)] - [(user/client-offset) 65] - [(default-size) 800]) - (min default-size - (- w user/client-offset) - (- h user/client-offset)))) - - (define-struct turtle (x y angle)) - ; x : int - ; y: int - ; angle : int - - (define-struct cached (turtles cache)) - ; turtles : (list-of turtle) - ; cache : turtle -> turtle - - (define-struct tree (children)) - ; children : (list-of cached) - - (define clear-turtle (make-turtle (/ turtle-window-size 2) - (/ turtle-window-size 2) 0)) - - ;; turtles-state is either a - ;; - (list-of turtle) or - ;; - tree - (define turtles-state (list clear-turtle)) - - ;; the cache contains a turtle-offset, which is represented - ;; by a turtle -- but it is a delta not an absolute. - (define empty-cache (make-turtle 0 0 0)) - (define turtles-cache empty-cache) - - (define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles)."))) - (define inner-line init-error) - (define inner-wipe-line init-error) - (define inner-clear-window init-error) - (define inner-flip-icons init-error) - (define inner-save-turtle-bitmap init-error) - - (define line - (lambda (a b c d) - (set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing)) - (inner-line a b c d))) - (define do-wipe-line - (lambda (a b c d) - (set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing)) - (inner-wipe-line a b c d))) - (define (flip-icons) (inner-flip-icons)) - - (define clear-window (lambda () (inner-clear-window))) - (define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y))) - - (define turtles - (case-lambda - [() (turtles #t)] - [(x) - (set! turtles:shown? x) - (unless turtles:window - (set! turtles:window - (make-object plot-window% - "Turtles" - turtle-window-size - turtle-window-size)) - (set! inner-line (lambda x (send turtles:window draw-line . x))) - (set! inner-wipe-line (lambda x (send turtles:window wipe-line . x))) - (set! inner-clear-window (lambda x (send turtles:window clear . x))) - (set! inner-save-turtle-bitmap (lambda x (send turtles:window save-turtle-bitmap . x))) - (set! flip-icons (lambda x (send turtles:window flip-icons . x)))) - (send turtles:window show x) - (send turtles:window get-canvas)])) - - (define clear - (lambda () - (set! turtles-cache empty-cache) - (set! turtles-state (list clear-turtle)) - (set! lines-in-drawing null) - (clear-window))) - - ;; cache elements: - (define-struct c-forward (distance)) - (define-struct c-turn (angle)) - (define-struct c-draw (distance)) - (define-struct c-offset (x y)) - - ;; combines a cache-element and a turtle-offset. - ;; turtle-offsets are represented as turtles, - ;; however they are deltas, not absolutes. - (define combine - (lambda (entry cache) - (cond - [(c-forward? entry) - (let* ([n (c-forward-distance entry)] - [angle (turtle-angle cache)] - [x (turtle-x cache)] - [y (turtle-y cache)] - [newx (+ x (* n (cos angle)))] - [newy (+ y (* n (sin angle)))]) - (make-turtle newx newy angle))] - [(c-offset? entry) - (let* ([tx (turtle-x cache)] - [ty (turtle-y cache)] - [newx (+ tx (c-offset-x entry))] - [newy (+ ty (c-offset-y entry))]) - (make-turtle newx newy - (turtle-angle cache)))] - [(c-turn? entry) - (make-turtle (turtle-x cache) - (turtle-y cache) - (- (turtle-angle cache) - (c-turn-angle entry)))] - [else - (error 'turtles-cache "illegal entry in cache: ~a" entry)]))) - - ;; this applies an offset to a turtle. - ;; an offset is a turtle, representing what would happen - ;; if the turtle had started at zero. - (define apply-cache - (lambda (offset) - (let ([x (turtle-x offset)] - [y (turtle-y offset)] - [offset-angle (turtle-angle offset)]) - (lambda (turtle) - (let* ([angle (turtle-angle turtle)]) - (let* ([c (cos angle)] - [s (sin angle)] - [rx (- (* x c) (* y s))] - [ry (+ (* y c) (* x s))]) - (make-turtle (+ rx (turtle-x turtle)) - (+ ry (turtle-y turtle)) - (+ offset-angle angle)))))))) - - (define flatten - (lambda (at-end) - (letrec ([walk-turtles - (lambda (turtles cache list) - (cond - [(tree? turtles) - (let ([children (tree-children turtles)] - [ac (apply-cache cache)]) - (foldl (lambda (child list) - (walk-turtles (cached-turtles child) - (ac (cached-cache child)) - list)) - list - children))] - [else - (let ([f (compose at-end (apply-cache cache))]) - (foldl (lambda (t l) (cons (f t) l)) list turtles))]))]) - (set! turtles-state (walk-turtles turtles-state turtles-cache null)) - (set! turtles-cache empty-cache)))) - - (define draw/erase - (lambda (doit) - (lambda (n) + (let ([f (compose at-end (apply-cache cache))]) + (foldl (lambda (t l) (cons (f t) l)) list turtles))]))]) + (set! turtles-state (walk-turtles turtles-state turtles-cache null)) + (set! turtles-cache empty-cache)))) + +(define draw/erase + (lambda (doit) + (lambda (n) + (flip-icons) + (flatten + (lambda (turtle) + (let* ([x (turtle-x turtle)] + [y (turtle-y turtle)] + [angle (turtle-angle turtle)] + [d (if (zero? n) 0 (sub1 (abs n)))] + [res (if (< n 0) (- d) d)] + [c (cos angle)] + [s (sin angle)] + [drawx (+ x (* res c))] + [drawy (+ y (* res s))] + [newx (+ x (* n c))] + [newy (+ y (* n s))]) + (unless (zero? n) + (doit x y drawx drawy)) + (make-turtle newx newy angle)))) + (flip-icons)))) + +(define draw (draw/erase (lambda (a b c d) (line a b c d)))) +(define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d)))) + +(define move + (lambda (n) + (flip-icons) + (set! turtles-cache (combine (make-c-forward n) turtles-cache)) + (flip-icons))) + +(define turn/radians + (lambda (d) + (flip-icons) + (set! turtles-cache (combine (make-c-turn d) turtles-cache)) + (flip-icons))) + +(define turn + (lambda (c) + (turn/radians (* (/ c 360) 2 pi)))) + +(define move-offset + (lambda (x y) + (flip-icons) + (set! turtles-cache (combine (make-c-offset x y) turtles-cache)) + (flip-icons))) + +(define erase/draw-offset + (lambda (doit) + (lambda (x y) + (flip-icons) + (flatten + (lambda (turtle) + (let* ([tx (turtle-x turtle)] + [ty (turtle-y turtle)] + [newx (+ tx x)] + [newy (+ ty y)]) + (doit tx ty newx newy) + (make-turtle newx newy (turtle-angle turtle))))) + (flip-icons)))) + +(define erase-offset (erase/draw-offset (lambda (a b c d) (do-wipe-line a b c d)))) +(define draw-offset (erase/draw-offset (lambda (a b c d) (line a b c d)))) + +(define splitfn + (lambda (e) + (let ([t turtles-state] + [c turtles-cache]) + (e) + (flip-icons) + (set! turtles-state + (make-tree (list (make-cached turtles-state turtles-cache) + (make-cached t c)))) + (set! turtles-cache empty-cache) + (flip-icons)))) + +(define split*fn + (lambda (es) + (let ([t turtles-state] + [c turtles-cache] + [l '()]) + (for-each (lambda (x) + (x) + (set! l (cons (make-cached turtles-state turtles-cache) l)) + (flip-icons) + (set! turtles-state t) + (set! turtles-cache c) + (flip-icons)) + es) + (flip-icons) + (set! turtles-cache empty-cache) + (set! turtles-state (make-tree l)) + (flip-icons)))) + + +(define tpromptfn + (lambda (thunk) + (let ([save-turtles-cache #f] + [save-turtles-state #f]) + (dynamic-wind + (lambda () + (set! save-turtles-cache turtles-cache) + (set! save-turtles-state turtles-state)) + (lambda () + (thunk)) + (lambda () (flip-icons) - (flatten - (lambda (turtle) - (let* ([x (turtle-x turtle)] - [y (turtle-y turtle)] - [angle (turtle-angle turtle)] - [d (if (zero? n) 0 (sub1 (abs n)))] - [res (if (< n 0) (- d) d)] - [c (cos angle)] - [s (sin angle)] - [drawx (+ x (* res c))] - [drawy (+ y (* res s))] - [newx (+ x (* n c))] - [newy (+ y (* n s))]) - (unless (zero? n) - (doit x y drawx drawy)) - (make-turtle newx newy angle)))) - (flip-icons)))) - - (define draw (draw/erase (lambda (a b c d) (line a b c d)))) - (define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d)))) - - (define move - (lambda (n) - (flip-icons) - (set! turtles-cache (combine (make-c-forward n) turtles-cache)) - (flip-icons))) - - (define turn/radians - (lambda (d) - (flip-icons) - (set! turtles-cache (combine (make-c-turn d) turtles-cache)) - (flip-icons))) - - (define turn - (lambda (c) - (turn/radians (* (/ c 360) 2 pi)))) - - (define move-offset - (lambda (x y) - (flip-icons) - (set! turtles-cache (combine (make-c-offset x y) turtles-cache)) - (flip-icons))) - - (define erase/draw-offset - (lambda (doit) - (lambda (x y) - (flip-icons) - (flatten - (lambda (turtle) - (let* ([tx (turtle-x turtle)] - [ty (turtle-y turtle)] - [newx (+ tx x)] - [newy (+ ty y)]) - (doit tx ty newx newy) - (make-turtle newx newy (turtle-angle turtle))))) - (flip-icons)))) - - (define erase-offset (erase/draw-offset (lambda (a b c d) (do-wipe-line a b c d)))) - (define draw-offset (erase/draw-offset (lambda (a b c d) (line a b c d)))) - - (define splitfn - (lambda (e) - (let ([t turtles-state] - [c turtles-cache]) - (e) - (flip-icons) - (set! turtles-state - (make-tree (list (make-cached turtles-state turtles-cache) - (make-cached t c)))) - (set! turtles-cache empty-cache) - (flip-icons)))) - - (define split*fn - (lambda (es) - (let ([t turtles-state] - [c turtles-cache] - [l '()]) - (for-each (lambda (x) - (x) - (set! l (cons (make-cached turtles-state turtles-cache) l)) - (flip-icons) - (set! turtles-state t) - (set! turtles-cache c) - (flip-icons)) - es) - (flip-icons) - (set! turtles-cache empty-cache) - (set! turtles-state (make-tree l)) - (flip-icons)))) - - - (define tpromptfn - (lambda (thunk) - (let ([save-turtles-cache #f] - [save-turtles-state #f]) - (dynamic-wind - (lambda () - (set! save-turtles-cache turtles-cache) - (set! save-turtles-state turtles-state)) - (lambda () - (thunk)) - (lambda () - (flip-icons) - (set! turtles-cache save-turtles-cache) - (set! turtles-state save-turtles-state) - (flip-icons)))))) - - - (define-struct drawing-line (x1 y1 x2 y2)) - (define-struct (wipe-line drawing-line) ()) - (define-struct (draw-line drawing-line) ()) - (define lines-in-drawing null) - - (define (draw-lines-into-dc dc) - (for-each (lambda (line) - (cond - [(wipe-line? line) (send dc set-pen w-pen)] - [(draw-line? line) (send dc set-pen b-pen)]) - (send dc draw-line - (drawing-line-x1 line) - (drawing-line-y1 line) - (drawing-line-x2 line) - (drawing-line-y2 line))) - lines-in-drawing)) - - ;; used to test printing - (define (display-lines-in-drawing) - (let* ([lines-in-drawing-canvas% - (class100 mred:canvas% (frame) - (inherit get-dc) - (override - [on-paint - (lambda () - (draw-lines-into-dc (get-dc)))]) - (sequence - (super-init frame)))] - [frame (make-object mred:frame% "Lines in Drawing")] - [canvas (make-object lines-in-drawing-canvas% frame)]) - (send frame show #t))) - - - (define (print) - (case (system-type) - [(macos macosx windows) - (let ([dc (make-object mred:printer-dc%)]) - (send dc start-doc "Turtles") - (send dc start-page) - (draw-lines-into-dc dc) - (send dc end-page) - (send dc end-doc))] - [(unix) - (let ([dc (make-object mred:post-script-dc%)]) - (send dc start-doc "Turtles") - (send dc start-page) - (draw-lines-into-dc dc) - (send dc end-page) - (send dc end-doc))] - [else - (mred:message-box "Turtles" - "Printing is not supported on this platform")])) + (set! turtles-cache save-turtles-cache) + (set! turtles-state save-turtles-state) + (flip-icons)))))) + + +(define-struct drawing-line (x1 y1 x2 y2)) +(define-struct (wipe-line drawing-line) ()) +(define-struct (draw-line drawing-line) ()) +(define lines-in-drawing null) + +(define (draw-lines-into-dc dc) + (for-each (lambda (line) + (cond + [(wipe-line? line) (send dc set-pen w-pen)] + [(draw-line? line) (send dc set-pen b-pen)]) + (send dc draw-line + (drawing-line-x1 line) + (drawing-line-y1 line) + (drawing-line-x2 line) + (drawing-line-y2 line))) + lines-in-drawing)) + +;; used to test printing +(define (display-lines-in-drawing) + (let* ([lines-in-drawing-canvas% + (class100 mred:canvas% (frame) + (inherit get-dc) + (override + [on-paint + (lambda () + (draw-lines-into-dc (get-dc)))]) + (sequence + (super-init frame)))] + [frame (make-object mred:frame% "Lines in Drawing")] + [canvas (make-object lines-in-drawing-canvas% frame)]) + (send frame show #t))) + + +(define (print) + (case (system-type) + [(macos macosx windows) + (let ([dc (make-object mred:printer-dc%)]) + (send dc start-doc "Turtles") + (send dc start-page) + (draw-lines-into-dc dc) + (send dc end-page) + (send dc end-doc))] + [(unix) + (let ([dc (make-object mred:post-script-dc%)]) + (send dc start-doc "Turtles") + (send dc start-page) + (draw-lines-into-dc dc) + (send dc end-page) + (send dc end-doc))] + [else + (mred:message-box "Turtles" + "Printing is not supported on this platform")])) diff --git a/collects/launcher/launcher-unit.ss b/collects/launcher/launcher-unit.ss index 82e77d3a6c..6f09821f8e 100644 --- a/collects/launcher/launcher-unit.ss +++ b/collects/launcher/launcher-unit.ss @@ -1,712 +1,710 @@ #lang scheme/unit - (require (lib "file.ss") - (lib "string.ss") - (lib "etc.ss") +(require scheme/file - (lib "compile-sig.ss" "dynext") - (lib "link-sig.ss" "dynext") - (lib "embed.ss" "compiler") - (lib "dirs.ss" "setup") - (lib "variant.ss" "setup") + (lib "compile-sig.ss" "dynext") + (lib "link-sig.ss" "dynext") + (lib "embed.ss" "compiler") + (lib "dirs.ss" "setup") + (lib "variant.ss" "setup") - "launcher-sig.ss" + "launcher-sig.ss" - (lib "winutf16.ss" "compiler" "private")) + (lib "winutf16.ss" "compiler" "private")) - (import (prefix c: dynext:compile^) - (prefix l: dynext:link^)) - (export launcher^) +(import (prefix c: dynext:compile^) + (prefix l: dynext:link^)) +(export launcher^) - (define current-launcher-variant - (make-parameter (system-type 'gc) - (lambda (v) - (unless (memq v '(3m script-3m cgc script-cgc)) - (raise-type-error - 'current-launcher-variant - "variant symbol" - v)) - v))) +(define current-launcher-variant + (make-parameter (system-type 'gc) + (lambda (v) + (unless (memq v '(3m script-3m cgc script-cgc)) + (raise-type-error + 'current-launcher-variant + "variant symbol" + v)) + v))) - (define (variant-available? kind cased-kind-name variant) - (cond - [(or (eq? 'unix (system-type)) - (and (eq? 'macosx (system-type)) - (eq? kind 'mzscheme))) - (let ([bin-dir (find-console-bin-dir)]) - (and bin-dir - (file-exists? (build-path - bin-dir - (format "~a~a" kind (variant-suffix variant #f))))))] - [(eq? 'macosx (system-type)) - ;; kind must be mred, because mzscheme case is caught above - (directory-exists? (build-path (find-gui-bin-dir) - (format "~a~a.app" - cased-kind-name - (variant-suffix variant #f))))] - [(eq? 'windows (system-type)) - (file-exists? (build-path (if (eq? kind 'mzscheme) - (find-console-bin-dir) - (find-gui-bin-dir)) - (format "~a~a.exe" - cased-kind-name - (variant-suffix variant #t))))] - [else (error "unknown system type")])) +(define (variant-available? kind cased-kind-name variant) + (cond + [(or (eq? 'unix (system-type)) + (and (eq? 'macosx (system-type)) + (eq? kind 'mzscheme))) + (let ([bin-dir (find-console-bin-dir)]) + (and bin-dir + (file-exists? (build-path + bin-dir + (format "~a~a" kind (variant-suffix variant #f))))))] + [(eq? 'macosx (system-type)) + ;; kind must be mred, because mzscheme case is caught above + (directory-exists? (build-path (find-gui-bin-dir) + (format "~a~a.app" + cased-kind-name + (variant-suffix variant #f))))] + [(eq? 'windows (system-type)) + (file-exists? (build-path (if (eq? kind 'mzscheme) + (find-console-bin-dir) + (find-gui-bin-dir)) + (format "~a~a.exe" + cased-kind-name + (variant-suffix variant #t))))] + [else (error "unknown system type")])) - (define (available-variants kind) - (let* ([cased-kind-name (if (eq? kind 'mzscheme) - "MzScheme" - "MrEd")] - [normal-kind (system-type 'gc)] - [alt-kind (if (eq? '3m normal-kind) - 'cgc - '3m)] - [normal (if (variant-available? kind cased-kind-name normal-kind) - (list normal-kind) - null)] - [alt (if (variant-available? kind cased-kind-name alt-kind) - (list alt-kind) - null)] - [script (if (and (eq? 'macosx (system-type)) - (eq? kind 'mred) - (pair? normal)) - (if (eq? normal-kind '3m) - '(script-3m) - '(script-cgc)) - null)] - [script-alt (if (and (memq alt-kind alt) - (pair? script)) - (if (eq? alt-kind '3m) - '(script-3m) - '(script-cgc)) - null)]) - (append normal alt script script-alt))) +(define (available-variants kind) + (let* ([cased-kind-name (if (eq? kind 'mzscheme) + "MzScheme" + "MrEd")] + [normal-kind (system-type 'gc)] + [alt-kind (if (eq? '3m normal-kind) + 'cgc + '3m)] + [normal (if (variant-available? kind cased-kind-name normal-kind) + (list normal-kind) + null)] + [alt (if (variant-available? kind cased-kind-name alt-kind) + (list alt-kind) + null)] + [script (if (and (eq? 'macosx (system-type)) + (eq? kind 'mred) + (pair? normal)) + (if (eq? normal-kind '3m) + '(script-3m) + '(script-cgc)) + null)] + [script-alt (if (and (memq alt-kind alt) + (pair? script)) + (if (eq? alt-kind '3m) + '(script-3m) + '(script-cgc)) + null)]) + (append normal alt script script-alt))) - (define (available-mred-variants) - (available-variants 'mred)) +(define (available-mred-variants) + (available-variants 'mred)) - (define (available-mzscheme-variants) - (available-variants 'mzscheme)) +(define (available-mzscheme-variants) + (available-variants 'mzscheme)) - (define (install-template dest kind mz mr) - (define src (build-path (collection-path "launcher") - (if (eq? kind 'mzscheme) mz mr))) - (when (or (file-exists? dest) - (directory-exists? dest) - (link-exists? dest)) - (delete-directory/files dest)) - (copy-file src dest)) +(define (install-template dest kind mz mr) + (define src (build-path (collection-path "launcher") + (if (eq? kind 'mzscheme) mz mr))) + (when (or (file-exists? dest) + (directory-exists? dest) + (link-exists? dest)) + (delete-directory/files dest)) + (copy-file src dest)) - (define (script-variant? v) - (memq v '(script-3m script-cgc))) +(define (script-variant? v) + (memq v '(script-3m script-cgc))) - (define (add-file-suffix path variant mred?) - (let ([s (variant-suffix variant (case (system-type) - [(unix) #f] - [(windows) #t] - [(macosx) (and mred? - (not (script-variant? variant)))]))]) - (if (string=? "" s) - path - (if (and (eq? 'windows (system-type)) - (regexp-match #rx#"[.]exe$" (path->bytes path))) - (path-replace-suffix path (string->bytes/utf-8 - (format "~a.exe" s))) - (path-replace-suffix path (string->bytes/utf-8 s)))))) - - (define (string-append/spaces f flags) - (if (null? flags) - "" - (string-append - (f (car flags)) - " " - (string-append/spaces f (cdr flags))))) - - (define (str-list->sh-str flags) - (letrec ([trans - (lambda (s) - (cond - [(regexp-match "(.*)'(.*)" s) - => (lambda (m) - (string-append (trans (cadr m)) - "\"'\"" - (trans (caddr m))))] - [else (format "'~a'" s)]))]) - (string-append/spaces trans flags))) - - (define (str-list->dos-str flags) - (letrec ([trans - (lambda (s) - (if (or (regexp-match (string #\[ #\space #\newline #\tab #\return #\vtab #\]) s) - (regexp-match "\"" s) - (regexp-match "\\\\" s)) - (list->string - (let loop ([l (string->list s)][wrote-slash 0]) - (cond - [(null? l) null] - [(char-whitespace? (car l)) - (append - (string->list (make-string wrote-slash #\\)) - (list #\" (car l) #\") - (loop (cdr l) 0))] - [else - (case (car l) - [(#\\) (cons #\\ (loop (cdr l) (add1 wrote-slash)))] - [(#\") (append - (string->list (make-string wrote-slash #\\)) - `(#\" #\\ #\" #\") - (loop (cdr l) 0))] - [else (cons (car l) (loop (cdr l) 0))])]))) - s))]) - (string-append/spaces trans flags))) +(define (add-file-suffix path variant mred?) + (let ([s (variant-suffix variant (case (system-type) + [(unix) #f] + [(windows) #t] + [(macosx) (and mred? + (not (script-variant? variant)))]))]) + (if (string=? "" s) + path + (if (and (eq? 'windows (system-type)) + (regexp-match #rx#"[.]exe$" (path->bytes path))) + (path-replace-suffix path (string->bytes/utf-8 + (format "~a.exe" s))) + (path-replace-suffix path (string->bytes/utf-8 s)))))) - (define one-arg-x-flags '((xa "-display") - (xb "-geometry") - (xc "-bg" "-background") - (xd "-fg" "-foregound") - (xe "-font") - (xf "-name") - (xg "-selectionTimeout") - (xh "-title") - (xi "-xnllanguage") - (xj "-xrm"))) - (define no-arg-x-flags '((xk "-iconic") - (xl "-rv" "-reverse") - (xm "+rv") - (xn "-synchronous") - (xo "-singleInstance"))) +(define (string-append/spaces f flags) + (if (null? flags) + "" + (string-append + (f (car flags)) + " " + (string-append/spaces f (cdr flags))))) - (define (skip-x-flags flags) - (let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))]) - (let loop ([f flags]) - (if (null? f) - null - (if (ormap (xfmem (car f)) one-arg-x-flags) - (if (null? (cdr f)) - null - (loop (cddr f))) - (if (ormap (xfmem (car f)) no-arg-x-flags) - (loop (cdr f)) - f)))))) +(define (str-list->sh-str flags) + (letrec ([trans + (lambda (s) + (cond + [(regexp-match "(.*)'(.*)" s) + => (lambda (m) + (string-append (trans (cadr m)) + "\"'\"" + (trans (caddr m))))] + [else (format "'~a'" s)]))]) + (string-append/spaces trans flags))) - (define (output-x-arg-getter exec args) - (let ([or-flags - (lambda (l) - (if (null? (cdr l)) - (car l) - (string-append - (car l) - (apply - string-append - (map (lambda (s) (string-append " | " s)) (cdr l))))))]) - (apply - string-append - (append - (list "# Find X flags and shift them to the front\n" - "findxend() {\n" - " oneargflag=''\n" - " case \"$1\" in\n") - (map - (lambda (f) - (format (string-append - " ~a)\n" - " oneargflag=\"$1\"\n" - " ~a=\"$2\"\n" - " ;;\n") - (or-flags (cdr f)) - (car f))) - one-arg-x-flags) - (map - (lambda (f) - (format " ~a)\n ~a=yes\n ;;\n" (or-flags (cdr f)) (car f))) - no-arg-x-flags) - (list - (format (string-append - " *)\n ~a~a ~a ;;\n" - " esac\n" - " shift\n" - " if [ \"$oneargflag\" != '' ] ; then\n" - " if [ \"${1+n}\" != 'n' ] ; then echo $0: missing argument for standard X flag $oneargflag ; exit 1 ; fi\n" - " shift\n" - " fi\n" - " findxend ${1+\"$@\"}\n" - "}\nfindxend ${1+\"$@\"}\n") - exec - (apply - string-append - (append - (map - (lambda (f) (format " ${~a+\"~a\"} ${~a+\"$~a\"}" (car f) (cadr f) (car f) (car f))) - one-arg-x-flags) - (map - (lambda (f) (format " ${~a+\"~a\"}" (car f) (cadr f))) - no-arg-x-flags))) - args)))))) +(define (str-list->dos-str flags) + (letrec ([trans + (lambda (s) + (if (or (regexp-match (string #\[ #\space #\newline #\tab #\return #\vtab #\]) s) + (regexp-match "\"" s) + (regexp-match "\\\\" s)) + (list->string + (let loop ([l (string->list s)][wrote-slash 0]) + (cond + [(null? l) null] + [(char-whitespace? (car l)) + (append + (string->list (make-string wrote-slash #\\)) + (list #\" (car l) #\") + (loop (cdr l) 0))] + [else + (case (car l) + [(#\\) (cons #\\ (loop (cdr l) (add1 wrote-slash)))] + [(#\") (append + (string->list (make-string wrote-slash #\\)) + `(#\" #\\ #\" #\") + (loop (cdr l) 0))] + [else (cons (car l) (loop (cdr l) 0))])]))) + s))]) + (string-append/spaces trans flags))) - (define (protect-shell-string s) - (regexp-replace* - #rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&")) +(define one-arg-x-flags '((xa "-display") + (xb "-geometry") + (xc "-bg" "-background") + (xd "-fg" "-foregound") + (xe "-font") + (xf "-name") + (xg "-selectionTimeout") + (xh "-title") + (xi "-xnllanguage") + (xj "-xrm"))) +(define no-arg-x-flags '((xk "-iconic") + (xl "-rv" "-reverse") + (xm "+rv") + (xn "-synchronous") + (xo "-singleInstance"))) - (define (normalize+explode-path p) - (explode-path (normal-case-path (normalize-path p)))) +(define (skip-x-flags flags) + (let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))]) + (let loop ([f flags]) + (if (null? f) + null + (if (ormap (xfmem (car f)) one-arg-x-flags) + (if (null? (cdr f)) + null + (loop (cddr f))) + (if (ormap (xfmem (car f)) no-arg-x-flags) + (loop (cdr f)) + f)))))) - (define (relativize bindir-explode dest-explode) - (let loop ([b bindir-explode] [d dest-explode]) - (if (and (pair? b) (equal? (car b) (car d))) - (loop (cdr b) (cdr d)) - (let ([p (append (map (lambda (x) 'up) (cdr d)) b)]) - (if (null? p) - #f - (apply build-path p)))))) +(define (output-x-arg-getter exec args) + (let ([or-flags + (lambda (l) + (if (null? (cdr l)) + (car l) + (string-append + (car l) + (apply + string-append + (map (lambda (s) (string-append " | " s)) (cdr l))))))]) + (apply + string-append + (append + (list "# Find X flags and shift them to the front\n" + "findxend() {\n" + " oneargflag=''\n" + " case \"$1\" in\n") + (map + (lambda (f) + (format (string-append + " ~a)\n" + " oneargflag=\"$1\"\n" + " ~a=\"$2\"\n" + " ;;\n") + (or-flags (cdr f)) + (car f))) + one-arg-x-flags) + (map + (lambda (f) + (format " ~a)\n ~a=yes\n ;;\n" (or-flags (cdr f)) (car f))) + no-arg-x-flags) + (list + (format (string-append + " *)\n ~a~a ~a ;;\n" + " esac\n" + " shift\n" + " if [ \"$oneargflag\" != '' ] ; then\n" + " if [ \"${1+n}\" != 'n' ] ; then echo $0: missing argument for standard X flag $oneargflag ; exit 1 ; fi\n" + " shift\n" + " fi\n" + " findxend ${1+\"$@\"}\n" + "}\nfindxend ${1+\"$@\"}\n") + exec + (apply + string-append + (append + (map + (lambda (f) (format " ${~a+\"~a\"} ${~a+\"$~a\"}" (car f) (cadr f) (car f) (car f))) + one-arg-x-flags) + (map + (lambda (f) (format " ${~a+\"~a\"}" (car f) (cadr f))) + no-arg-x-flags))) + args)))))) - (define (make-relative-path-header dest bindir) - ;; rely only on binaries in /usr/bin:/bin - (define (has-exe? exe) - (or (file-exists? (build-path "/usr/bin" exe)) - (file-exists? (build-path "/bin" exe)))) - (let* ([has-readlink? (and (not (eq? 'macosx (system-type))) - (has-exe? "readlink"))] - [dest-explode (normalize+explode-path dest)] - [bindir-explode (normalize+explode-path bindir)]) - (if (and (has-exe? "dirname") (has-exe? "basename") - (or has-readlink? (and (has-exe? "ls") (has-exe? "sed"))) - (equal? (car dest-explode) (car bindir-explode))) - (string-append - "# Make this PATH-independent\n" - "saveP=\"$PATH\"\n" - "PATH=\"/usr/bin:/bin\"\n" - "\n" - (if has-readlink? "" - (string-append - "# imitate possibly-missing readlink\n" - "readlink() {\n" - " ls -l -- \"$1\" | sed -e \"s/^.* -> //\"\n" - "}\n" - "\n")) - "# Remember current directory\n" - "saveD=`pwd`\n" - "\n" - "# Find absolute path to this script,\n" - "# resolving symbolic references to the end\n" - "# (changes the current directory):\n" - "D=`dirname \"$0\"`\n" - "F=`basename \"$0\"`\n" - "cd \"$D\"\n" - "while test " - ;; On solaris, Edward Chrzanowski from Waterloo says that the man - ;; page says that -L is not supported, but -h is; on other systems - ;; (eg, freebsd) -h is listed as a compatibility feature - (if (regexp-match #rx"solaris" (path->string - (system-library-subpath))) - "-h" "-L") - " \"$F\"; do\n" - " P=`readlink \"$F\"`\n" - " D=`dirname \"$P\"`\n" - " F=`basename \"$P\"`\n" - " cd \"$D\"\n" - "done\n" - "D=`pwd`\n" - "\n" - "# Restore current directory\n" - "cd \"$saveD\"\n" - "\n" - "bindir=\"$D" - (let ([s (relativize bindir-explode dest-explode)]) - (if s - (string-append "/" - (protect-shell-string s)) - "")) - "\"\n" - "PATH=\"$saveP\"\n") - ;; fallback to absolute path header - (make-absolute-path-header bindir)))) +(define (protect-shell-string s) + (regexp-replace* + #rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&")) - (define (make-absolute-path-header bindir) - (string-append "bindir=\""(protect-shell-string bindir)"\"\n")) +(define (normalize+explode-path p) + (explode-path (normal-case-path (normalize-path p)))) - (define (make-unix-launcher kind variant flags dest aux) - (install-template dest kind "sh" "sh") ; just for something that's executable - (let* ([alt-exe (let ([m (and (eq? kind 'mred) - (script-variant? variant) - (assq 'exe-name aux))]) - (and m - (format "~a~a.app/Contents/MacOS/~a~a" - (cdr m) (variant-suffix variant #t) - (cdr m) (variant-suffix variant #t))))] - [x-flags? (and (eq? kind 'mred) - (eq? (system-type) 'unix) - (not (script-variant? variant)))] - [post-flags (cond - [x-flags? (skip-x-flags flags)] - [alt-exe null] - [else flags])] - [pre-flags (cond - [(not x-flags?) null] - [else - (let loop ([f flags]) - (if (eq? f post-flags) - null - (cons (car f) (loop (cdr f)))))])] - [pre-str (str-list->sh-str pre-flags)] - [post-str (str-list->sh-str post-flags)] - [header (string-append - "#!/bin/sh\n" - "# This script was created by make-" - (symbol->string kind)"-launcher\n")] - [dir-finder - (let ([bindir (if alt-exe - (find-gui-bin-dir) - (find-console-bin-dir))]) - (if (let ([a (assq 'relative? aux)]) - (and a (cdr a))) - (make-relative-path-header dest bindir) - (make-absolute-path-header bindir)))] - [exec (format - "exec \"${bindir}/~a~a\" ~a" - (or alt-exe kind) - (if alt-exe "" (variant-suffix variant #f)) - pre-str)] - [args (format - "~a~a ${1+\"$@\"}\n" - (if alt-exe "" "-N \"$0\" ") - post-str)] - [assemble-exec (if (and (eq? kind 'mred) - (not (script-variant? variant)) - (not (null? post-flags))) - output-x-arg-getter - string-append)]) - (unless (find-console-bin-dir) - (error 'make-unix-launcher "unable to locate bin directory")) - (with-output-to-file dest - (lambda () - (display header) - (newline) - ;; comments needed to rehack launchers when paths change - ;; (see setup/unixstyle-install.ss) - (display "# {{{ bindir\n") - (display dir-finder) - (display "# }}} bindir\n") - (newline) - (display (assemble-exec exec args))) - 'truncate))) +(define (relativize bindir-explode dest-explode) + (let loop ([b bindir-explode] [d dest-explode]) + (if (and (pair? b) (equal? (car b) (car d))) + (loop (cdr b) (cdr d)) + (let ([p (append (map (lambda (x) 'up) (cdr d)) b)]) + (if (null? p) + #f + (apply build-path p)))))) - (define (utf-16-regexp b) - (byte-regexp (bytes-append (bytes->utf-16-bytes b) - #"[^>]*" - (bytes->utf-16-bytes #">")))) +(define (make-relative-path-header dest bindir) + ;; rely only on binaries in /usr/bin:/bin + (define (has-exe? exe) + (or (file-exists? (build-path "/usr/bin" exe)) + (file-exists? (build-path "/bin" exe)))) + (let* ([has-readlink? (and (not (eq? 'macosx (system-type))) + (has-exe? "readlink"))] + [dest-explode (normalize+explode-path dest)] + [bindir-explode (normalize+explode-path bindir)]) + (if (and (has-exe? "dirname") (has-exe? "basename") + (or has-readlink? (and (has-exe? "ls") (has-exe? "sed"))) + (equal? (car dest-explode) (car bindir-explode))) + (string-append + "# Make this PATH-independent\n" + "saveP=\"$PATH\"\n" + "PATH=\"/usr/bin:/bin\"\n" + "\n" + (if has-readlink? "" + (string-append + "# imitate possibly-missing readlink\n" + "readlink() {\n" + " ls -l -- \"$1\" | sed -e \"s/^.* -> //\"\n" + "}\n" + "\n")) + "# Remember current directory\n" + "saveD=`pwd`\n" + "\n" + "# Find absolute path to this script,\n" + "# resolving symbolic references to the end\n" + "# (changes the current directory):\n" + "D=`dirname \"$0\"`\n" + "F=`basename \"$0\"`\n" + "cd \"$D\"\n" + "while test " + ;; On solaris, Edward Chrzanowski from Waterloo says that the man + ;; page says that -L is not supported, but -h is; on other systems + ;; (eg, freebsd) -h is listed as a compatibility feature + (if (regexp-match #rx"solaris" (path->string + (system-library-subpath))) + "-h" "-L") + " \"$F\"; do\n" + " P=`readlink \"$F\"`\n" + " D=`dirname \"$P\"`\n" + " F=`basename \"$P\"`\n" + " cd \"$D\"\n" + "done\n" + "D=`pwd`\n" + "\n" + "# Restore current directory\n" + "cd \"$saveD\"\n" + "\n" + "bindir=\"$D" + (let ([s (relativize bindir-explode dest-explode)]) + (if s + (string-append "/" + (protect-shell-string s)) + "")) + "\"\n" + "PATH=\"$saveP\"\n") + ;; fallback to absolute path header + (make-absolute-path-header bindir)))) - (define (make-windows-launcher kind variant flags dest aux) - (if (not (and (let ([m (assq 'independent? aux)]) - (and m (cdr m))))) - ;; Normal launcher: - (make-embedding-executable dest (eq? kind 'mred) #f - null null null - flags - aux - #t - variant) - ;; Independent launcher (needed for Setup PLT): - (begin - (install-template dest kind "mzstart.exe" "mrstart.exe") - (let ([bstr (bytes->utf-16-bytes - (string->bytes/utf-8 (str-list->dos-str flags)))] - [p (open-input-file dest)] - [m (utf-16-regexp #"utf-16-bytes - (bytes-append - (path->bytes (let ([bin-dir (if (eq? kind 'mred) - (find-gui-bin-dir) - (find-console-bin-dir))]) - (if (let ([m (assq 'relative? aux)]) - (and m (cdr m))) - (or (relativize (normalize+explode-path bin-dir) - (normalize+explode-path dest)) - (build-path 'same)) - bin-dir))) - ;; null wchar marks end of executable directory - #"\0\0"))] - [find-it ; Find the magic start - (lambda (magic s) - (file-position p 0) - (let ([m (regexp-match-positions magic p)]) - (if m - (car m) - (begin - (close-input-port p) - (when (file-exists? dest) - (delete-file dest)) - (error - 'make-windows-launcher - (format - "Couldn't find ~a position in template" s))))))] - [exedir-poslen (find-it x "executable path")] - [command-poslen (find-it m "command-line")] - [variant-poslen (find-it v "variant")] - [pos-exedir (car exedir-poslen)] - [len-exedir (- (cdr exedir-poslen) (car exedir-poslen))] - [pos-command (car command-poslen)] - [len-command (- (cdr command-poslen) (car command-poslen))] - [pos-variant (car variant-poslen)] - [space (char->integer #\space)] - [write-magic - (lambda (p s pos len) - (file-position p pos) - (display s p) - (display (make-bytes (- len (bytes-length s)) space) p))] - [check-len - (lambda (len s es) - (when (> (bytes-length s) len) - (when (file-exists? dest) - (delete-file dest)) - (error - (format - "~a exceeds limit of ~a characters with ~a characters: ~a" - es len (string-length s) s))))]) - (close-input-port p) - (check-len len-exedir exedir "executable home directory") - (check-len len-command bstr "collection/file name") - (let ([p (open-output-file dest 'update)]) - (write-magic p exedir pos-exedir len-exedir) - (write-magic p (bytes-append bstr #"\0\0") pos-command len-command) - (let* ([suffix (variant-suffix (current-launcher-variant) #t)] - [suffix-bytes (bytes-append - (list->bytes - (apply append - (map (lambda (c) (list c 0)) - (bytes->list (string->bytes/latin-1 suffix))))) - #"\0\0")]) - (write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes))) - (close-output-port p))))))) +(define (make-absolute-path-header bindir) + (string-append "bindir=\""(protect-shell-string bindir)"\"\n")) - ;; OS X launcher code: +(define (make-unix-launcher kind variant flags dest aux) + (install-template dest kind "sh" "sh") ; just for something that's executable + (let* ([alt-exe (let ([m (and (eq? kind 'mred) + (script-variant? variant) + (assq 'exe-name aux))]) + (and m + (format "~a~a.app/Contents/MacOS/~a~a" + (cdr m) (variant-suffix variant #t) + (cdr m) (variant-suffix variant #t))))] + [x-flags? (and (eq? kind 'mred) + (eq? (system-type) 'unix) + (not (script-variant? variant)))] + [post-flags (cond + [x-flags? (skip-x-flags flags)] + [alt-exe null] + [else flags])] + [pre-flags (cond + [(not x-flags?) null] + [else + (let loop ([f flags]) + (if (eq? f post-flags) + null + (cons (car f) (loop (cdr f)))))])] + [pre-str (str-list->sh-str pre-flags)] + [post-str (str-list->sh-str post-flags)] + [header (string-append + "#!/bin/sh\n" + "# This script was created by make-" + (symbol->string kind)"-launcher\n")] + [dir-finder + (let ([bindir (if alt-exe + (find-gui-bin-dir) + (find-console-bin-dir))]) + (if (let ([a (assq 'relative? aux)]) + (and a (cdr a))) + (make-relative-path-header dest bindir) + (make-absolute-path-header bindir)))] + [exec (format + "exec \"${bindir}/~a~a\" ~a" + (or alt-exe kind) + (if alt-exe "" (variant-suffix variant #f)) + pre-str)] + [args (format + "~a~a ${1+\"$@\"}\n" + (if alt-exe "" "-N \"$0\" ") + post-str)] + [assemble-exec (if (and (eq? kind 'mred) + (not (script-variant? variant)) + (not (null? post-flags))) + output-x-arg-getter + string-append)]) + (unless (find-console-bin-dir) + (error 'make-unix-launcher "unable to locate bin directory")) + (with-output-to-file dest + #:exists 'truncate + (lambda () + (display header) + (newline) + ;; comments needed to rehack launchers when paths change + ;; (see setup/unixstyle-install.ss) + (display "# {{{ bindir\n") + (display dir-finder) + (display "# }}} bindir\n") + (newline) + (display (assemble-exec exec args)))))) - ; make-macosx-launcher : symbol (listof str) pathname -> - (define (make-macosx-launcher kind variant flags dest aux) - (if (or (eq? kind 'mzscheme) - (script-variant? variant)) - ;; MzScheme or script launcher is the same as for Unix - (make-unix-launcher kind variant flags dest aux) - ;; MrEd "launcher" is a stand-alone executable - (make-embedding-executable dest (eq? kind 'mred) #f - null null null - flags - aux - #t - variant))) +(define (utf-16-regexp b) + (byte-regexp (bytes-append (bytes->utf-16-bytes b) + #"[^>]*" + (bytes->utf-16-bytes #">")))) - (define (make-macos-launcher kind variant flags dest aux) - (install-template dest kind "GoMr" "GoMr") - (let ([p (open-input-file dest)]) - (let ([m (regexp-match-positions #rx#"" p)]) - ;; fast-forward to the end: - (let ([s (make-bytes 4096)]) - (let loop () - (if (eof-object? (read-bytes! s p)) - (file-position p) - (loop)))) - (let ([data-fork-size (file-position p)]) - (close-input-port p) - (let ([p (open-output-file dest 'update)] - [str (str-list->sh-str (append - (if (eq? kind 'mred) - null - '("-Z")) - flags))]) - (file-position p (caar m)) - (display (integer->integer-bytes (string-length str) 4 #t #t) p) - (display (integer->integer-bytes data-fork-size 4 #t #t) p) - (file-position p data-fork-size) - (display str p) - (close-output-port p)))))) +(define (make-windows-launcher kind variant flags dest aux) + (if (not (and (let ([m (assq 'independent? aux)]) + (and m (cdr m))))) + ;; Normal launcher: + (make-embedding-executable dest (eq? kind 'mred) #f + null null null + flags + aux + #t + variant) + ;; Independent launcher (needed for Setup PLT): + (begin + (install-template dest kind "mzstart.exe" "mrstart.exe") + (let ([bstr (bytes->utf-16-bytes + (string->bytes/utf-8 (str-list->dos-str flags)))] + [p (open-input-file dest)] + [m (utf-16-regexp #"utf-16-bytes + (bytes-append + (path->bytes (let ([bin-dir (if (eq? kind 'mred) + (find-gui-bin-dir) + (find-console-bin-dir))]) + (if (let ([m (assq 'relative? aux)]) + (and m (cdr m))) + (or (relativize (normalize+explode-path bin-dir) + (normalize+explode-path dest)) + (build-path 'same)) + bin-dir))) + ;; null wchar marks end of executable directory + #"\0\0"))] + [find-it ; Find the magic start + (lambda (magic s) + (file-position p 0) + (let ([m (regexp-match-positions magic p)]) + (if m + (car m) + (begin + (close-input-port p) + (when (file-exists? dest) + (delete-file dest)) + (error + 'make-windows-launcher + (format + "Couldn't find ~a position in template" s))))))] + [exedir-poslen (find-it x "executable path")] + [command-poslen (find-it m "command-line")] + [variant-poslen (find-it v "variant")] + [pos-exedir (car exedir-poslen)] + [len-exedir (- (cdr exedir-poslen) (car exedir-poslen))] + [pos-command (car command-poslen)] + [len-command (- (cdr command-poslen) (car command-poslen))] + [pos-variant (car variant-poslen)] + [space (char->integer #\space)] + [write-magic + (lambda (p s pos len) + (file-position p pos) + (display s p) + (display (make-bytes (- len (bytes-length s)) space) p))] + [check-len + (lambda (len s es) + (when (> (bytes-length s) len) + (when (file-exists? dest) + (delete-file dest)) + (error + (format + "~a exceeds limit of ~a characters with ~a characters: ~a" + es len (string-length s) s))))]) + (close-input-port p) + (check-len len-exedir exedir "executable home directory") + (check-len len-command bstr "collection/file name") + (let ([p (open-output-file dest 'update)]) + (write-magic p exedir pos-exedir len-exedir) + (write-magic p (bytes-append bstr #"\0\0") pos-command len-command) + (let* ([suffix (variant-suffix (current-launcher-variant) #t)] + [suffix-bytes (bytes-append + (list->bytes + (apply append + (map (lambda (c) (list c 0)) + (bytes->list (string->bytes/latin-1 suffix))))) + #"\0\0")]) + (write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes))) + (close-output-port p))))))) - (define (get-maker) - (case (system-type) - [(unix) make-unix-launcher] - [(windows) make-windows-launcher] - [(macos) make-macos-launcher] - [(macosx) make-macosx-launcher])) +;; OS X launcher code: - (define make-mred-launcher - (opt-lambda (flags dest [aux null]) - (let ([variant (current-launcher-variant)]) - ((get-maker) 'mred variant flags dest aux)))) + ; make-macosx-launcher : symbol (listof str) pathname -> +(define (make-macosx-launcher kind variant flags dest aux) + (if (or (eq? kind 'mzscheme) + (script-variant? variant)) + ;; MzScheme or script launcher is the same as for Unix + (make-unix-launcher kind variant flags dest aux) + ;; MrEd "launcher" is a stand-alone executable + (make-embedding-executable dest (eq? kind 'mred) #f + null null null + flags + aux + #t + variant))) - (define make-mzscheme-launcher - (opt-lambda (flags dest [aux null]) - (let ([variant (current-launcher-variant)]) - ((get-maker) 'mzscheme variant flags dest aux)))) +(define (make-macos-launcher kind variant flags dest aux) + (install-template dest kind "GoMr" "GoMr") + (let ([p (open-input-file dest)]) + (let ([m (regexp-match-positions #rx#"" p)]) + ;; fast-forward to the end: + (let ([s (make-bytes 4096)]) + (let loop () + (if (eof-object? (read-bytes! s p)) + (file-position p) + (loop)))) + (let ([data-fork-size (file-position p)]) + (close-input-port p) + (let ([p (open-output-file dest 'update)] + [str (str-list->sh-str (append + (if (eq? kind 'mred) + null + '("-Z")) + flags))]) + (file-position p (caar m)) + (display (integer->integer-bytes (string-length str) 4 #t #t) p) + (display (integer->integer-bytes data-fork-size 4 #t #t) p) + (file-position p data-fork-size) + (display str p) + (close-output-port p)))))) - (define (strip-suffix s) - (path-replace-suffix s #"")) +(define (get-maker) + (case (system-type) + [(unix) make-unix-launcher] + [(windows) make-windows-launcher] + [(macos) make-macos-launcher] + [(macosx) make-macosx-launcher])) - (define (build-aux-from-path aux-root) - (let ([aux-root (if (string? aux-root) - (string->path aux-root) - aux-root)]) - (let ([try (lambda (key suffix) - (let ([p (path-replace-suffix aux-root suffix)]) - (if (file-exists? p) - (list (cons key p)) - null)))]) - (append - (try 'icns #".icns") - (try 'ico #".ico") - (try 'independent? #".lch") - (let ([l (try 'creator #".creator")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) - (with-input-from-file (cdar l) - (lambda () - (let ([s (read-string 4)]) - (if s - (list (cons (caar l) s)) - null))))))) - (let ([l (try 'file-types #".filetypes")]) - (if (null? l) - l - (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) - (with-input-from-file (cdar l) - (lambda () - (let ([d (read)]) - (let-values ([(local-dir base dir?) (split-path aux-root)]) - (let ([icon-files - (apply - append - (map (lambda (spec) - (let ([m (assoc "CFBundleTypeIconFile" spec)]) - (if m - (list (build-path - (path->complete-path local-dir) - (format "~a.icns" (cadr m)))) - null))) - d))]) - (list - (cons 'file-types d) - (cons 'resource-files icon-files)))))))))))))) +(define make-mred-launcher + (lambda (flags dest [aux null]) + (let ([variant (current-launcher-variant)]) + ((get-maker) 'mred variant flags dest aux)))) - (define (make-mred-program-launcher file collection dest) - (make-mred-launcher (list "-mqvL" file collection "--") - dest - (build-aux-from-path - (build-path (collection-path collection) - (strip-suffix file))))) - - (define (make-mzscheme-program-launcher file collection dest) - (make-mzscheme-launcher (list "-mqvL" file collection "--") - dest - (build-aux-from-path - (build-path (collection-path collection) - (strip-suffix file))))) +(define make-mzscheme-launcher + (lambda (flags dest [aux null]) + (let ([variant (current-launcher-variant)]) + ((get-maker) 'mzscheme variant flags dest aux)))) - (define (unix-sfx file mred?) - (list->string - (map - (lambda (c) - (if (char-whitespace? c) - #\- - (char-downcase c))) - (string->list file)))) +(define (strip-suffix s) + (path-replace-suffix s #"")) - (define (sfx file mred?) - (case (system-type) - [(unix) (unix-sfx file mred?)] - [(windows) (string-append (if mred? file (unix-sfx file mred?)) - ".exe")] - [else file])) +(define (build-aux-from-path aux-root) + (let ([aux-root (if (string? aux-root) + (string->path aux-root) + aux-root)]) + (let ([try (lambda (key suffix) + (let ([p (path-replace-suffix aux-root suffix)]) + (if (file-exists? p) + (list (cons key p)) + null)))]) + (append + (try 'icns #".icns") + (try 'ico #".ico") + (try 'independent? #".lch") + (let ([l (try 'creator #".creator")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) + (with-input-from-file (cdar l) + (lambda () + (let ([s (read-string 4)]) + (if s + (list (cons (caar l) s)) + null))))))) + (let ([l (try 'file-types #".filetypes")]) + (if (null? l) + l + (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) + (with-input-from-file (cdar l) + (lambda () + (let ([d (read)]) + (let-values ([(local-dir base dir?) (split-path aux-root)]) + (let ([icon-files + (apply + append + (map (lambda (spec) + (let ([m (assoc "CFBundleTypeIconFile" spec)]) + (if m + (list (build-path + (path->complete-path local-dir) + (format "~a.icns" (cadr m)))) + null))) + d))]) + (list + (cons 'file-types d) + (cons 'resource-files icon-files)))))))))))))) - (define (program-launcher-path name mred?) - (let* ([variant (current-launcher-variant)] - [mac-script? (and (eq? (system-type) 'macosx) - (script-variant? variant))]) - (let ([p (add-file-suffix - (build-path - (if (or mac-script? (not mred?)) - (find-console-bin-dir) - (find-gui-bin-dir)) - ((if mac-script? unix-sfx sfx) name mred?)) - variant - mred?)]) - (if (and (eq? (system-type) 'macosx) - (not (script-variant? variant))) - (path-replace-suffix p #".app") - p)))) +(define (make-mred-program-launcher file collection dest) + (make-mred-launcher (list "-mqvL" file collection "--") + dest + (build-aux-from-path + (build-path (collection-path collection) + (strip-suffix file))))) - (define (mred-program-launcher-path name) - (program-launcher-path name #t)) - - (define (mzscheme-program-launcher-path name) - (case (system-type) - [(macosx) (add-file-suffix - (build-path (find-console-bin-dir) (unix-sfx name #f)) - (current-launcher-variant) - #f)] - [else (program-launcher-path name #f)])) - - (define (mred-launcher-is-directory?) - #f) - (define (mzscheme-launcher-is-directory?) - #f) +(define (make-mzscheme-program-launcher file collection dest) + (make-mzscheme-launcher (list "-mqvL" file collection "--") + dest + (build-aux-from-path + (build-path (collection-path collection) + (strip-suffix file))))) - (define (mred-launcher-is-actually-directory?) - (and (eq? 'macosx (system-type)) - (not (script-variant? (current-launcher-variant))))) - (define (mzscheme-launcher-is-actually-directory?) - #f) +(define (unix-sfx file mred?) + (list->string + (map + (lambda (c) + (if (char-whitespace? c) + #\- + (char-downcase c))) + (string->list file)))) - ;; Helper: - (define (put-file-extension+style+filters type) - (case type - [(windows) (values "exe" null '(("Executable" "*.exe")))] - [(macosx) (values "app" '(packages) '(("App" "*.app")))] - [else (values #f null null)])) - - (define (mred-launcher-add-suffix path) - (embedding-executable-add-suffix path #t)) +(define (sfx file mred?) + (case (system-type) + [(unix) (unix-sfx file mred?)] + [(windows) (string-append (if mred? file (unix-sfx file mred?)) + ".exe")] + [else file])) - (define (mzscheme-launcher-add-suffix path) - (embedding-executable-add-suffix path #f)) +(define (program-launcher-path name mred?) + (let* ([variant (current-launcher-variant)] + [mac-script? (and (eq? (system-type) 'macosx) + (script-variant? variant))]) + (let ([p (add-file-suffix + (build-path + (if (or mac-script? (not mred?)) + (find-console-bin-dir) + (find-gui-bin-dir)) + ((if mac-script? unix-sfx sfx) name mred?)) + variant + mred?)]) + (if (and (eq? (system-type) 'macosx) + (not (script-variant? variant))) + (path-replace-suffix p #".app") + p)))) - (define (mred-launcher-put-file-extension+style+filters) - (put-file-extension+style+filters - (if (and (eq? 'macosx (system-type)) - (script-variant? (current-launcher-variant))) - 'unix - (system-type)))) +(define (mred-program-launcher-path name) + (program-launcher-path name #t)) - (define (mzscheme-launcher-put-file-extension+style+filters) - (put-file-extension+style+filters - (if (eq? 'macosx (system-type)) - 'unix - (system-type)))) +(define (mzscheme-program-launcher-path name) + (case (system-type) + [(macosx) (add-file-suffix + (build-path (find-console-bin-dir) (unix-sfx name #f)) + (current-launcher-variant) + #f)] + [else (program-launcher-path name #f)])) - (define mred-launcher-up-to-date? - (opt-lambda (dest [aux null]) - (mzscheme-launcher-up-to-date? dest aux))) +(define (mred-launcher-is-directory?) + #f) +(define (mzscheme-launcher-is-directory?) + #f) - (define mzscheme-launcher-up-to-date? - (opt-lambda (dest [aux null]) - (cond - ;; When running Setup PLT under Windows, the - ;; launcher process stays running until MzScheme - ;; completes, which means that it cannot be - ;; overwritten at that time. So we assume - ;; that a Setup-PLT-style independent launcher - ;; is always up-to-date. - [(eq? 'windows (system-type)) - (and (let ([m (assq 'independent? aux)]) - (and m (cdr m))) - (file-exists? dest))] - ;; For any other setting, we could implement - ;; a fancy check, but for now always re-create - ;; launchers. - [else #f]))) +(define (mred-launcher-is-actually-directory?) + (and (eq? 'macosx (system-type)) + (not (script-variant? (current-launcher-variant))))) +(define (mzscheme-launcher-is-actually-directory?) + #f) - (define (install-mred-program-launcher file collection name) - (make-mred-program-launcher file collection (mred-program-launcher-path name))) - - (define (install-mzscheme-program-launcher file collection name) - (make-mzscheme-program-launcher file collection (mzscheme-program-launcher-path name))) +;; Helper: +(define (put-file-extension+style+filters type) + (case type + [(windows) (values "exe" null '(("Executable" "*.exe")))] + [(macosx) (values "app" '(packages) '(("App" "*.app")))] + [else (values #f null null)])) + +(define (mred-launcher-add-suffix path) + (embedding-executable-add-suffix path #t)) + +(define (mzscheme-launcher-add-suffix path) + (embedding-executable-add-suffix path #f)) + +(define (mred-launcher-put-file-extension+style+filters) + (put-file-extension+style+filters + (if (and (eq? 'macosx (system-type)) + (script-variant? (current-launcher-variant))) + 'unix + (system-type)))) + +(define (mzscheme-launcher-put-file-extension+style+filters) + (put-file-extension+style+filters + (if (eq? 'macosx (system-type)) + 'unix + (system-type)))) + +(define mred-launcher-up-to-date? + (lambda (dest [aux null]) + (mzscheme-launcher-up-to-date? dest aux))) + +(define mzscheme-launcher-up-to-date? + (lambda (dest [aux null]) + (cond + ;; When running Setup PLT under Windows, the + ;; launcher process stays running until MzScheme + ;; completes, which means that it cannot be + ;; overwritten at that time. So we assume + ;; that a Setup-PLT-style independent launcher + ;; is always up-to-date. + [(eq? 'windows (system-type)) + (and (let ([m (assq 'independent? aux)]) + (and m (cdr m))) + (file-exists? dest))] + ;; For any other setting, we could implement + ;; a fancy check, but for now always re-create + ;; launchers. + [else #f]))) + +(define (install-mred-program-launcher file collection name) + (make-mred-program-launcher file collection (mred-program-launcher-path name))) + +(define (install-mzscheme-program-launcher file collection name) + (make-mzscheme-program-launcher file collection (mzscheme-program-launcher-path name))) diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss index 164cc36593..268ed859e5 100644 --- a/collects/mzlib/cm.ss +++ b/collects/mzlib/cm.ss @@ -131,7 +131,20 @@ [code (parameterize ([param (lambda (ext-file) (set! external-deps (cons (path->bytes ext-file) - external-deps)))]) + external-deps)))] + [current-reader-guard + (let ([rg (current-reader-guard)]) + (lambda (d) + (let ([d (rg d)]) + (when (module-path? d) + (let ([p (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join d #f)))]) + (when (path? p) + (set! external-deps + (cons (path->bytes p) + external-deps))))) + d)))]) (get-module-code path mode))] [code-dir (get-code-dir mode path)]) (if (not (directory-exists? code-dir)) diff --git a/collects/net/base64-unit.ss b/collects/net/base64-unit.ss index 79f21175f7..55cecc63c7 100644 --- a/collects/net/base64-unit.ss +++ b/collects/net/base64-unit.ss @@ -1,49 +1,48 @@ - #lang scheme/unit - (require "base64-sig.ss") +(require "base64-sig.ss") - (import) - (export base64^) +(import) +(export base64^) - (define base64-digit (make-vector 256)) - (let loop ([n 0]) - (unless (= n 256) - (cond [(<= (char->integer #\A) n (char->integer #\Z)) - (vector-set! base64-digit n (- n (char->integer #\A)))] - [(<= (char->integer #\a) n (char->integer #\z)) - (vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))] - [(<= (char->integer #\0) n (char->integer #\9)) - (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))] - [(= (char->integer #\+) n) - (vector-set! base64-digit n 62)] - [(= (char->integer #\/) n) - (vector-set! base64-digit n 63)] - [else - (vector-set! base64-digit n #f)]) - (loop (add1 n)))) +(define base64-digit (make-vector 256)) +(let loop ([n 0]) + (unless (= n 256) + (cond [(<= (char->integer #\A) n (char->integer #\Z)) + (vector-set! base64-digit n (- n (char->integer #\A)))] + [(<= (char->integer #\a) n (char->integer #\z)) + (vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))] + [(<= (char->integer #\0) n (char->integer #\9)) + (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))] + [(= (char->integer #\+) n) + (vector-set! base64-digit n 62)] + [(= (char->integer #\/) n) + (vector-set! base64-digit n 63)] + [else + (vector-set! base64-digit n #f)]) + (loop (add1 n)))) - (define digit-base64 (make-vector 64)) - (define (each-char s e pos) - (let loop ([i (char->integer s)][pos pos]) - (unless (> i (char->integer e)) - (vector-set! digit-base64 pos i) - (loop (add1 i) (add1 pos))))) - (each-char #\A #\Z 0) - (each-char #\a #\z 26) - (each-char #\0 #\9 52) - (each-char #\+ #\+ 62) - (each-char #\/ #\/ 63) +(define digit-base64 (make-vector 64)) +(define (each-char s e pos) + (let loop ([i (char->integer s)][pos pos]) + (unless (> i (char->integer e)) + (vector-set! digit-base64 pos i) + (loop (add1 i) (add1 pos))))) +(each-char #\A #\Z 0) +(each-char #\a #\z 26) +(each-char #\0 #\9 52) +(each-char #\+ #\+ 62) +(each-char #\/ #\/ 63) - (define (base64-filename-safe) - (vector-set! base64-digit (char->integer #\-) 62) - (vector-set! base64-digit (char->integer #\_) 63) - (each-char #\- #\- 62) - (each-char #\_ #\_ 63)) +(define (base64-filename-safe) + (vector-set! base64-digit (char->integer #\-) 62) + (vector-set! base64-digit (char->integer #\_) 63) + (each-char #\- #\- 62) + (each-char #\_ #\_ 63)) - (define (base64-decode-stream in out) - (let loop ([waiting 0][waiting-bits 0]) - (if (>= waiting-bits 8) +(define (base64-decode-stream in out) + (let loop ([waiting 0][waiting-bits 0]) + (if (>= waiting-bits 8) (begin (write-byte (arithmetic-shift waiting (- 8 waiting-bits)) out) (let ([waiting-bits (- waiting-bits 8)]) @@ -57,79 +56,79 @@ [(eq? c (char->integer #\=)) (void)] ; done [else (loop waiting waiting-bits)]))))) - (define base64-encode-stream - (case-lambda - [(in out) (base64-encode-stream in out #"\n")] - [(in out linesep) - ;; Process input 3 characters at a time, because 18 bits - ;; is divisible by both 6 and 8, and 72 (the line length) - ;; is divisible by 3. - (let ([three (make-bytes 3)] - [outc (lambda (n) - (write-byte (vector-ref digit-base64 n) out))] - [done (lambda (fill) - (let loop ([fill fill]) - (unless (zero? fill) - (write-byte (char->integer #\=) out) - (loop (sub1 fill)))) - (display linesep out))]) - (let loop ([pos 0]) - (if (= pos 72) - ;; Insert newline - (begin - (display linesep out) - (loop 0)) - ;; Next group of 3 - (let ([n (read-bytes-avail! three in)]) - (cond - [(eof-object? n) - (unless (= pos 0) (done 0))] - [(= n 3) - ;; Easy case: - (let ([a (bytes-ref three 0)] - [b (bytes-ref three 1)] - [c (bytes-ref three 2)]) - (outc (arithmetic-shift a -2)) - (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) - (arithmetic-shift b -4))) - (outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) - (arithmetic-shift c -6))) - (outc (bitwise-and #x3f c)) - (loop (+ pos 4)))] - [else - ;; Hard case: n is 1 or 2 - (let ([a (bytes-ref three 0)]) - (outc (arithmetic-shift a -2)) - (let* ([next (if (= n 2) +(define base64-encode-stream + (case-lambda + [(in out) (base64-encode-stream in out #"\n")] + [(in out linesep) + ;; Process input 3 characters at a time, because 18 bits + ;; is divisible by both 6 and 8, and 72 (the line length) + ;; is divisible by 3. + (let ([three (make-bytes 3)] + [outc (lambda (n) + (write-byte (vector-ref digit-base64 n) out))] + [done (lambda (fill) + (let loop ([fill fill]) + (unless (zero? fill) + (write-byte (char->integer #\=) out) + (loop (sub1 fill)))) + (display linesep out))]) + (let loop ([pos 0]) + (if (= pos 72) + ;; Insert newline + (begin + (display linesep out) + (loop 0)) + ;; Next group of 3 + (let ([n (read-bytes-avail! three in)]) + (cond + [(eof-object? n) + (unless (= pos 0) (done 0))] + [(= n 3) + ;; Easy case: + (let ([a (bytes-ref three 0)] + [b (bytes-ref three 1)] + [c (bytes-ref three 2)]) + (outc (arithmetic-shift a -2)) + (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) + (arithmetic-shift b -4))) + (outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) + (arithmetic-shift c -6))) + (outc (bitwise-and #x3f c)) + (loop (+ pos 4)))] + [else + ;; Hard case: n is 1 or 2 + (let ([a (bytes-ref three 0)]) + (outc (arithmetic-shift a -2)) + (let* ([next (if (= n 2) (bytes-ref three 1) (read-byte in))] - [b (if (eof-object? next) + [b (if (eof-object? next) 0 next)]) - (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) - (arithmetic-shift b -4))) - (if (eof-object? next) + (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) + (arithmetic-shift b -4))) + (if (eof-object? next) (done 2) ;; More to go (let* ([next (read-byte in)] [c (if (eof-object? next) - 0 - next)]) + 0 + next)]) (outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) (arithmetic-shift c -6))) (if (eof-object? next) - (done 1) - ;; Finish c, loop - (begin - (outc (bitwise-and #x3f c)) - (loop (+ pos 4))))))))])))))])) + (done 1) + ;; Finish c, loop + (begin + (outc (bitwise-and #x3f c)) + (loop (+ pos 4))))))))])))))])) - (define (base64-decode src) - (let ([s (open-output-bytes)]) - (base64-decode-stream (open-input-bytes src) s) - (get-output-bytes s))) +(define (base64-decode src) + (let ([s (open-output-bytes)]) + (base64-decode-stream (open-input-bytes src) s) + (get-output-bytes s))) - (define (base64-encode src) - (let ([s (open-output-bytes)]) - (base64-encode-stream (open-input-bytes src) s (bytes 13 10)) - (get-output-bytes s))) +(define (base64-encode src) + (let ([s (open-output-bytes)]) + (base64-encode-stream (open-input-bytes src) s (bytes 13 10)) + (get-output-bytes s))) diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss index e1fdf790a0..1011f58c70 100644 --- a/collects/net/cookie-unit.ss +++ b/collects/net/cookie-unit.ss @@ -59,7 +59,7 @@ (import) (export cookie^) - (define-struct cookie (name value comment domain max-age path secure version)) + (define-struct cookie (name value comment domain max-age path secure version) #:mutable) (define-struct (cookie-error exn:fail) ()) ;; error* : string args ... -> raises a cookie-error exception diff --git a/collects/net/dns-unit.ss b/collects/net/dns-unit.ss index 7008c848d4..4476f1dfda 100644 --- a/collects/net/dns-unit.ss +++ b/collects/net/dns-unit.ss @@ -1,6 +1,7 @@ #lang scheme/unit - (require (lib "list.ss") (lib "process.ss") "dns-sig.ss") + (require (lib "list.ss") (lib "process.ss") "dns-sig.ss" + scheme/udp) (import) (export dns^) diff --git a/collects/net/ftp-unit.ss b/collects/net/ftp-unit.ss index 9815f67a37..2895e98447 100644 --- a/collects/net/ftp-unit.ss +++ b/collects/net/ftp-unit.ss @@ -1,82 +1,82 @@ #lang scheme/unit - ;; Version 0.2 - ;; Version 0.1a - ;; Micah Flatt - ;; 06-06-2002 - (require (lib "date.ss") (lib "file.ss") (lib "port.ss") "ftp-sig.ss") - (import) - (export ftp^) +;; Version 0.2 +;; Version 0.1a +;; Micah Flatt +;; 06-06-2002 +(require scheme/date scheme/file scheme/port scheme/tcp "ftp-sig.ss") +(import) +(export ftp^) - ;; opqaue record to represent an FTP connection: - (define-struct tcp-connection (in out)) +;; opqaue record to represent an FTP connection: +(define-struct tcp-connection (in out)) - (define tzoffset (date-time-zone-offset (seconds->date (current-seconds)))) +(define tzoffset (date-time-zone-offset (seconds->date (current-seconds)))) - (define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") - (define re:response-end #rx#"^[0-9][0-9][0-9] ") +(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") +(define re:response-end #rx#"^[0-9][0-9][0-9] ") - (define (check-expected-result line expected) - (when expected - (unless (ormap (lambda (expected) - (bytes=? expected (subbytes line 0 3))) - (if (bytes? expected) +(define (check-expected-result line expected) + (when expected + (unless (ormap (lambda (expected) + (bytes=? expected (subbytes line 0 3))) + (if (bytes? expected) (list expected) expected)) - (error 'ftp "exected result code ~a, got ~a" expected line)))) + (error 'ftp "exected result code ~a, got ~a" expected line)))) - ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any - ;; - ;; Checks a standard-format response, checking for the given - ;; expected 3-digit result code if expected is not #f. - ;; - ;; While checking, the function sends reponse lines to - ;; diagnostic-accum. This function -accum functions can return a - ;; value that accumulates over multiple calls to the function, and - ;; accum-start is used as the initial value. Use `void' and - ;; `(void)' to ignore the response info. - ;; - ;; If an unexpected result is found, an exception is raised, and the - ;; stream is left in an undefined state. - (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) - (flush-output tcpout) - (let ([line (read-bytes-line tcpin 'any)]) - (cond - [(eof-object? line) - (error 'ftp "unexpected EOF")] - [(regexp-match re:multi-response-start line) - (check-expected-result line expected) - (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) - (let loop ([accum (diagnostic-accum line accum-start)]) - (let ([line (read-bytes-line tcpin 'any)]) - (cond [(eof-object? line) - (error 'ftp "unexpected EOF")] - [(regexp-match re:done line) - (diagnostic-accum line accum)] - [else - (loop (diagnostic-accum line accum))]))))] - [(regexp-match re:response-end line) - (check-expected-result line expected) - (diagnostic-accum line accum-start)] - [else - (error 'ftp "unexpected result: ~e" line)]))) +;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any +;; +;; Checks a standard-format response, checking for the given +;; expected 3-digit result code if expected is not #f. +;; +;; While checking, the function sends reponse lines to +;; diagnostic-accum. This function -accum functions can return a +;; value that accumulates over multiple calls to the function, and +;; accum-start is used as the initial value. Use `void' and +;; `(void)' to ignore the response info. +;; +;; If an unexpected result is found, an exception is raised, and the +;; stream is left in an undefined state. +(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) + (flush-output tcpout) + (let ([line (read-bytes-line tcpin 'any)]) + (cond + [(eof-object? line) + (error 'ftp "unexpected EOF")] + [(regexp-match re:multi-response-start line) + (check-expected-result line expected) + (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) + (let loop ([accum (diagnostic-accum line accum-start)]) + (let ([line (read-bytes-line tcpin 'any)]) + (cond [(eof-object? line) + (error 'ftp "unexpected EOF")] + [(regexp-match re:done line) + (diagnostic-accum line accum)] + [else + (loop (diagnostic-accum line accum))]))))] + [(regexp-match re:response-end line) + (check-expected-result line expected) + (diagnostic-accum line accum-start)] + [else + (error 'ftp "unexpected result: ~e" line)]))) - (define (get-month month-bytes) - (cond [(assoc month-bytes - '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) - (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) - (#"Nov" 11) (#"Dec" 12))) - => cadr] - [else (error 'get-month "bad month: ~s" month-bytes)])) +(define (get-month month-bytes) + (cond [(assoc month-bytes + '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) + (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) + (#"Nov" 11) (#"Dec" 12))) + => cadr] + [else (error 'get-month "bad month: ~s" month-bytes)])) - (define (bytes->number bytes) - (string->number (bytes->string/latin-1 bytes))) +(define (bytes->number bytes) + (string->number (bytes->string/latin-1 bytes))) - (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") +(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") - (define (ftp-make-file-seconds ftp-date-str) - (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))]) - (if (not (list-ref date-list 4)) +(define (ftp-make-file-seconds ftp-date-str) + (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))]) + (if (not (list-ref date-list 4)) (find-seconds 0 0 2 @@ -91,128 +91,128 @@ 2002) tzoffset)))) - (define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") +(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") - (define (establish-data-connection tcp-ports) - (fprintf (tcp-connection-out tcp-ports) "PASV\n") - (let ([response (ftp-check-response - (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"227" - (lambda (s ignore) s) ; should be the only response - (void))]) - (let* ([reg-list (regexp-match re:passive response)] - [pn1 (and reg-list - (bytes->number (list-ref reg-list 5)))] - [pn2 (bytes->number (list-ref reg-list 6))]) - (unless (and reg-list pn1 pn2) - (error 'ftp "can't understand PASV response: ~e" response)) - (let-values ([(tcp-data tcp-data-out) - (tcp-connect (format "~a.~a.~a.~a" - (list-ref reg-list 1) - (list-ref reg-list 2) - (list-ref reg-list 3) - (list-ref reg-list 4)) - (+ (* 256 pn1) pn2))]) - (fprintf (tcp-connection-out tcp-ports) "TYPE I\n") - (ftp-check-response (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"200" void (void)) - (close-output-port tcp-data-out) - tcp-data)))) - - ;; Used where version 0.1a printed responses: - (define (print-msg s ignore) - ;; (printf "~a\n" s) - (void)) - - (define (ftp-establish-connection* in out username password) - (ftp-check-response in out #"220" print-msg (void)) - (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out) - (let ([no-password? (ftp-check-response - in out (list #"331" #"230") - (lambda (line 230?) - (or 230? (regexp-match #rx#"^230" line))) - #f)]) - (unless no-password? - (display (bytes-append #"PASS " (string->bytes/locale password) #"\n") - out) - (ftp-check-response in out #"230" void (void)))) - (make-tcp-connection in out)) - - (define (ftp-establish-connection server-address server-port username password) - (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) - (ftp-establish-connection* tcpin tcpout username password))) - - (define (ftp-close-connection tcp-ports) - (fprintf (tcp-connection-out tcp-ports) "QUIT\n") - (ftp-check-response (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"221" void (void)) - (close-input-port (tcp-connection-in tcp-ports)) - (close-output-port (tcp-connection-out tcp-ports))) - - (define (filter-tcp-data tcp-data-port regular-exp) - (let loop () - (let ([theline (read-bytes-line tcp-data-port 'any)]) - (cond [(or (eof-object? theline) (< (bytes-length theline) 3)) - null] - [(regexp-match regular-exp theline) - => (lambda (m) (cons (cdr m) (loop)))] - [else - ;; ignore unrecognized lines? - (loop)])))) - - (define (ftp-cd ftp-ports new-dir) - (display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n") - (tcp-connection-out ftp-ports)) - (ftp-check-response (tcp-connection-in ftp-ports) - (tcp-connection-out ftp-ports) - #"250" void (void))) - - (define re:dir-line - #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$") - - (define (ftp-directory-list tcp-ports) - (let ([tcp-data (establish-data-connection tcp-ports)]) - (fprintf (tcp-connection-out tcp-ports) "LIST\n") - (ftp-check-response (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"150" void (void)) - (let ([dir-list (filter-tcp-data tcp-data re:dir-line)]) - (close-input-port tcp-data) +(define (establish-data-connection tcp-ports) + (fprintf (tcp-connection-out tcp-ports) "PASV\n") + (let ([response (ftp-check-response + (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"227" + (lambda (s ignore) s) ; should be the only response + (void))]) + (let* ([reg-list (regexp-match re:passive response)] + [pn1 (and reg-list + (bytes->number (list-ref reg-list 5)))] + [pn2 (bytes->number (list-ref reg-list 6))]) + (unless (and reg-list pn1 pn2) + (error 'ftp "can't understand PASV response: ~e" response)) + (let-values ([(tcp-data tcp-data-out) + (tcp-connect (format "~a.~a.~a.~a" + (list-ref reg-list 1) + (list-ref reg-list 2) + (list-ref reg-list 3) + (list-ref reg-list 4)) + (+ (* 256 pn1) pn2))]) + (fprintf (tcp-connection-out tcp-ports) "TYPE I\n") (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) - #"226" print-msg (void)) - (map (lambda (l) (map bytes->string/locale l)) dir-list)))) + #"200" void (void)) + (close-output-port tcp-data-out) + tcp-data)))) - (define (ftp-download-file tcp-ports folder filename) - ;; Save the file under the name tmp.file, rename it once download is - ;; complete this assures we don't over write any existing file without - ;; having a good file down - (let* ([tmpfile (make-temporary-file - (string-append - (regexp-replace - #rx"~" - (path->string (build-path folder "ftptmp")) - "~~") - "~a"))] - [new-file (open-output-file tmpfile 'replace)] - [tcpstring (bytes-append #"RETR " - (string->bytes/locale filename) - #"\n")] - [tcp-data (establish-data-connection tcp-ports)]) - (display tcpstring (tcp-connection-out tcp-ports)) - (ftp-check-response (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"150" print-msg (void)) - (copy-port tcp-data new-file) - (close-output-port new-file) +;; Used where version 0.1a printed responses: +(define (print-msg s ignore) + ;; (printf "~a\n" s) + (void)) + +(define (ftp-establish-connection* in out username password) + (ftp-check-response in out #"220" print-msg (void)) + (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out) + (let ([no-password? (ftp-check-response + in out (list #"331" #"230") + (lambda (line 230?) + (or 230? (regexp-match #rx#"^230" line))) + #f)]) + (unless no-password? + (display (bytes-append #"PASS " (string->bytes/locale password) #"\n") + out) + (ftp-check-response in out #"230" void (void)))) + (make-tcp-connection in out)) + +(define (ftp-establish-connection server-address server-port username password) + (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) + (ftp-establish-connection* tcpin tcpout username password))) + +(define (ftp-close-connection tcp-ports) + (fprintf (tcp-connection-out tcp-ports) "QUIT\n") + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"221" void (void)) + (close-input-port (tcp-connection-in tcp-ports)) + (close-output-port (tcp-connection-out tcp-ports))) + +(define (filter-tcp-data tcp-data-port regular-exp) + (let loop () + (let ([theline (read-bytes-line tcp-data-port 'any)]) + (cond [(or (eof-object? theline) (< (bytes-length theline) 3)) + null] + [(regexp-match regular-exp theline) + => (lambda (m) (cons (cdr m) (loop)))] + [else + ;; ignore unrecognized lines? + (loop)])))) + +(define (ftp-cd ftp-ports new-dir) + (display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n") + (tcp-connection-out ftp-ports)) + (ftp-check-response (tcp-connection-in ftp-ports) + (tcp-connection-out ftp-ports) + #"250" void (void))) + +(define re:dir-line + #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$") + +(define (ftp-directory-list tcp-ports) + (let ([tcp-data (establish-data-connection tcp-ports)]) + (fprintf (tcp-connection-out tcp-ports) "LIST\n") + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"150" void (void)) + (let ([dir-list (filter-tcp-data tcp-data re:dir-line)]) (close-input-port tcp-data) (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) #"226" print-msg (void)) - (rename-file-or-directory tmpfile (build-path folder filename) #t))) + (map (lambda (l) (map bytes->string/locale l)) dir-list)))) - ;; (printf "FTP Client Installed...\n") +(define (ftp-download-file tcp-ports folder filename) + ;; Save the file under the name tmp.file, rename it once download is + ;; complete this assures we don't over write any existing file without + ;; having a good file down + (let* ([tmpfile (make-temporary-file + (string-append + (regexp-replace + #rx"~" + (path->string (build-path folder "ftptmp")) + "~~") + "~a"))] + [new-file (open-output-file tmpfile 'replace)] + [tcpstring (bytes-append #"RETR " + (string->bytes/locale filename) + #"\n")] + [tcp-data (establish-data-connection tcp-ports)]) + (display tcpstring (tcp-connection-out tcp-ports)) + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"150" print-msg (void)) + (copy-port tcp-data new-file) + (close-output-port new-file) + (close-input-port tcp-data) + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"226" print-msg (void)) + (rename-file-or-directory tmpfile (build-path folder filename) #t))) + +;; (printf "FTP Client Installed...\n") diff --git a/collects/net/imap-unit.ss b/collects/net/imap-unit.ss index 79d40756a5..14cf2f479c 100644 --- a/collects/net/imap-unit.ss +++ b/collects/net/imap-unit.ss @@ -1,6 +1,8 @@ #lang scheme/unit - (require (lib "list.ss") "imap-sig.ss" "private/rbtree.ss") + (require scheme/tcp + "imap-sig.ss" + "private/rbtree.ss") (import) (export imap^) @@ -252,7 +254,8 @@ (info-handler i))) (define-struct imap (r w exists recent unseen uidnext uidvalidity - expunges fetches new?)) + expunges fetches new?) + #:mutable) (define (imap-connection? v) (imap? v)) (define imap-port-number diff --git a/collects/net/mime-sig.ss b/collects/net/mime-sig.ss index da6db0fd44..ca911b0288 100644 --- a/collects/net/mime-sig.ss +++ b/collects/net/mime-sig.ss @@ -1,14 +1,14 @@ #lang scheme/signature ;; -- exceptions raised -- -(struct mime-error () -setters -constructor) -(struct unexpected-termination (msg) -setters -constructor) -(struct missing-multipart-boundary-parameter () -setters -constructor) -(struct malformed-multipart-entity (msg) -setters -constructor) -(struct empty-mechanism () -setters -constructor) -(struct empty-type () -setters -constructor) -(struct empty-subtype () -setters -constructor) -(struct empty-disposition-type () -setters -constructor) +(struct mime-error () #:omit-constructor) +(struct unexpected-termination (msg) #:omit-constructor) +(struct missing-multipart-boundary-parameter () #:omit-constructor) +(struct malformed-multipart-entity (msg) #:omit-constructor) +(struct empty-mechanism () #:omit-constructor) +(struct empty-type () #:omit-constructor) +(struct empty-subtype () #:omit-constructor) +(struct empty-disposition-type () #:omit-constructor) ;; -- basic mime structures -- (struct message (version entity fields)) diff --git a/collects/net/mime-unit.ss b/collects/net/mime-unit.ss index 2361b375c0..557b126c25 100644 --- a/collects/net/mime-unit.ss +++ b/collects/net/mime-unit.ss @@ -121,12 +121,15 @@ ("quicktime" . quicktime))) ;; Basic structures - (define-struct message (version entity fields)) + (define-struct message (version entity fields) + #:mutable) (define-struct entity (type subtype charset encoding disposition params id description other - fields parts body)) + fields parts body) + #:mutable) (define-struct disposition - (type filename creation modification read size params)) + (type filename creation modification read size params) + #:mutable) ;; Exceptions (define-struct mime-error ()) @@ -227,7 +230,7 @@ [(message multipart) (let ([boundary (entity-boundary entity)]) (when (not boundary) - (if (eq? 'multipart (entity-type entity)) + (when (eq? 'multipart (entity-type entity)) (raise (make-missing-multipart-boundary-parameter)))) (set-entity-parts! entity (map (lambda (part) diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss index 4bf91e680d..eee9b36feb 100644 --- a/collects/net/nntp-unit.ss +++ b/collects/net/nntp-unit.ss @@ -1,150 +1,150 @@ #lang scheme/unit - (require (lib "etc.ss") "nntp-sig.ss") +(require scheme/tcp "nntp-sig.ss") - (import) - (export nntp^) +(import) +(export nntp^) - ;; sender : oport - ;; receiver : iport - ;; server : string - ;; port : number +;; sender : oport +;; receiver : iport +;; server : string +;; port : number - (define-struct communicator (sender receiver server port)) +(define-struct communicator (sender receiver server port)) - ;; code : number - ;; text : string - ;; line : string - ;; communicator : communicator - ;; group : string - ;; article : number +;; code : number +;; text : string +;; line : string +;; communicator : communicator +;; group : string +;; article : number - (define-struct (nntp exn) ()) - (define-struct (unexpected-response nntp) (code text)) - (define-struct (bad-status-line nntp) (line)) - (define-struct (premature-close nntp) (communicator)) - (define-struct (bad-newsgroup-line nntp) (line)) - (define-struct (non-existent-group nntp) (group)) - (define-struct (article-not-in-group nntp) (article)) - (define-struct (no-group-selected nntp) ()) - (define-struct (article-not-found nntp) (article)) - (define-struct (authentication-rejected nntp) ()) +(define-struct (nntp exn) ()) +(define-struct (unexpected-response nntp) (code text)) +(define-struct (bad-status-line nntp) (line)) +(define-struct (premature-close nntp) (communicator)) +(define-struct (bad-newsgroup-line nntp) (line)) +(define-struct (non-existent-group nntp) (group)) +(define-struct (article-not-in-group nntp) (article)) +(define-struct (no-group-selected nntp) ()) +(define-struct (article-not-found nntp) (article)) +(define-struct (authentication-rejected nntp) ()) - ;; signal-error : - ;; (exn-args ... -> exn) x format-string x values ... -> - ;; exn-args -> () +;; signal-error : +;; (exn-args ... -> exn) x format-string x values ... -> +;; exn-args -> () - ;; - throws an exception +;; - throws an exception - (define (signal-error constructor format-string . args) - (lambda exn-args - (raise (apply constructor - (apply format format-string args) - (current-continuation-marks) - exn-args)))) +(define (signal-error constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (apply format format-string args) + (current-continuation-marks) + exn-args)))) - ;; default-nntpd-port-number : - ;; number +;; default-nntpd-port-number : +;; number - (define default-nntpd-port-number 119) +(define default-nntpd-port-number 119) - ;; connect-to-server*: - ;; input-port output-port -> communicator +;; connect-to-server*: +;; input-port output-port -> communicator - (define connect-to-server* - (case-lambda - [(receiver sender) - (connect-to-server* receiver sender "unspecified" "unspecified")] - [(receiver sender server-name port-number) - (file-stream-buffer-mode sender 'line) - (let ([communicator (make-communicator sender receiver server-name - port-number)]) - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(200 201) communicator] - [else ((signal-error make-unexpected-response - "unexpected connection response: ~s ~s" - code response) - code response)])))])) +(define connect-to-server* + (case-lambda + [(receiver sender) + (connect-to-server* receiver sender "unspecified" "unspecified")] + [(receiver sender server-name port-number) + (file-stream-buffer-mode sender 'line) + (let ([communicator (make-communicator sender receiver server-name + port-number)]) + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(200 201) communicator] + [else ((signal-error make-unexpected-response + "unexpected connection response: ~s ~s" + code response) + code response)])))])) - ;; connect-to-server : - ;; string [x number] -> commnicator +;; connect-to-server : +;; string [x number] -> commnicator - (define connect-to-server - (opt-lambda (server-name (port-number default-nntpd-port-number)) - (let-values ([(receiver sender) - (tcp-connect server-name port-number)]) - (connect-to-server* receiver sender server-name port-number)))) +(define connect-to-server + (lambda (server-name (port-number default-nntpd-port-number)) + (let-values ([(receiver sender) + (tcp-connect server-name port-number)]) + (connect-to-server* receiver sender server-name port-number)))) - ;; close-communicator : - ;; communicator -> () +;; close-communicator : +;; communicator -> () - (define (close-communicator communicator) - (close-input-port (communicator-receiver communicator)) - (close-output-port (communicator-sender communicator))) +(define (close-communicator communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator))) - ;; disconnect-from-server : - ;; communicator -> () +;; disconnect-from-server : +;; communicator -> () - (define (disconnect-from-server communicator) - (send-to-server communicator "QUIT") - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(205) - (close-communicator communicator)] - [else - ((signal-error make-unexpected-response - "unexpected dis-connect response: ~s ~s" - code response) - code response)]))) +(define (disconnect-from-server communicator) + (send-to-server communicator "QUIT") + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(205) + (close-communicator communicator)] + [else + ((signal-error make-unexpected-response + "unexpected dis-connect response: ~s ~s" + code response) + code response)]))) - ;; authenticate-user : - ;; communicator x user-name x password -> () - ;; the password is not used if the server does not ask for it. +;; authenticate-user : +;; communicator x user-name x password -> () +;; the password is not used if the server does not ask for it. - (define (authenticate-user communicator user password) - (define (reject code response) - ((signal-error make-authentication-rejected - "authentication rejected (~s ~s)" - code response))) - (define (unexpected code response) - ((signal-error make-unexpected-response - "unexpected response for authentication: ~s ~s" - code response) - code response)) - (send-to-server communicator "AUTHINFO USER ~a" user) - (let-values ([(code response) (get-single-line-response communicator)]) - (case code - [(281) (void)] ; server doesn't ask for a password - [(381) - (send-to-server communicator "AUTHINFO PASS ~a" password) - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(281) (void)] ; done - [(502) (reject code response)] - [else (unexpected code response)]))] - [(502) (reject code response)] - [else (reject code response) - (unexpected code response)]))) +(define (authenticate-user communicator user password) + (define (reject code response) + ((signal-error make-authentication-rejected + "authentication rejected (~s ~s)" + code response))) + (define (unexpected code response) + ((signal-error make-unexpected-response + "unexpected response for authentication: ~s ~s" + code response) + code response)) + (send-to-server communicator "AUTHINFO USER ~a" user) + (let-values ([(code response) (get-single-line-response communicator)]) + (case code + [(281) (void)] ; server doesn't ask for a password + [(381) + (send-to-server communicator "AUTHINFO PASS ~a" password) + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(281) (void)] ; done + [(502) (reject code response)] + [else (unexpected code response)]))] + [(502) (reject code response)] + [else (reject code response) + (unexpected code response)]))) - ;; send-to-server : - ;; communicator x format-string x list (values) -> () +;; send-to-server : +;; communicator x format-string x list (values) -> () - (define (send-to-server communicator message-template . rest) - (let ([sender (communicator-sender communicator)]) - (apply fprintf sender - (string-append message-template "\r\n") - rest) - (flush-output sender))) +(define (send-to-server communicator message-template . rest) + (let ([sender (communicator-sender communicator)]) + (apply fprintf sender + (string-append message-template "\r\n") + rest) + (flush-output sender))) - ;; parse-status-line : - ;; string -> number x string +;; parse-status-line : +;; string -> number x string - (define (parse-status-line line) - (if (eof-object? line) +(define (parse-status-line line) + (if (eof-object? line) ((signal-error make-bad-status-line "eof instead of a status line") line) (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line) @@ -154,99 +154,99 @@ (values (string->number (car match)) (cadr match))))) - ;; get-one-line-from-server : - ;; iport -> string +;; get-one-line-from-server : +;; iport -> string - (define (get-one-line-from-server server->client-port) - (read-line server->client-port 'return-linefeed)) +(define (get-one-line-from-server server->client-port) + (read-line server->client-port 'return-linefeed)) - ;; get-single-line-response : - ;; communicator -> number x string +;; get-single-line-response : +;; communicator -> number x string - (define (get-single-line-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)]) - (parse-status-line status-line))) +(define (get-single-line-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)]) + (parse-status-line status-line))) - ;; get-rest-of-multi-line-response : - ;; communicator -> list (string) +;; get-rest-of-multi-line-response : +;; communicator -> list (string) - (define (get-rest-of-multi-line-response communicator) - (let ([receiver (communicator-receiver communicator)]) - (let loop () - (let ([l (get-one-line-from-server receiver)]) - (cond - [(eof-object? l) - ((signal-error make-premature-close - "port prematurely closed during multi-line response") - communicator)] - [(string=? l ".") - '()] - [(string=? l "..") - (cons "." (loop))] - [else - (cons l (loop))]))))) +(define (get-rest-of-multi-line-response communicator) + (let ([receiver (communicator-receiver communicator)]) + (let loop () + (let ([l (get-one-line-from-server receiver)]) + (cond + [(eof-object? l) + ((signal-error make-premature-close + "port prematurely closed during multi-line response") + communicator)] + [(string=? l ".") + '()] + [(string=? l "..") + (cons "." (loop))] + [else + (cons l (loop))]))))) - ;; get-multi-line-response : - ;; communicator -> number x string x list (string) +;; get-multi-line-response : +;; communicator -> number x string x list (string) - ;; -- The returned values are the status code, the rest of the status - ;; response line, and the remaining lines. +;; -- The returned values are the status code, the rest of the status +;; response line, and the remaining lines. - (define (get-multi-line-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)]) - (let-values ([(code rest-of-line) - (parse-status-line status-line)]) - (values code rest-of-line (get-rest-of-multi-line-response))))) - - ;; open-news-group : - ;; communicator x string -> number x number x number - - ;; -- The returned values are the number of articles, the first - ;; article number, and the last article number for that group. - - (define (open-news-group communicator group-name) - (send-to-server communicator "GROUP ~a" group-name) +(define (get-multi-line-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)]) (let-values ([(code rest-of-line) - (get-single-line-response communicator)]) - (case code - [(211) - (let ([match (map string->number - (cdr - (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) - ((signal-error make-bad-newsgroup-line - "malformed newsgroup open response: ~s" - rest-of-line) - rest-of-line))))]) - (let ([number-of-articles (car match)] - [first-article-number (cadr match)] - [last-article-number (caddr match)]) - (values number-of-articles - first-article-number - last-article-number)))] - [(411) - ((signal-error make-non-existent-group - "group ~s does not exist on server ~s" - group-name (communicator-server communicator)) - group-name)] - [else - ((signal-error make-unexpected-response - "unexpected group opening response: ~s" code) - code rest-of-line)]))) + (parse-status-line status-line)]) + (values code rest-of-line (get-rest-of-multi-line-response))))) - ;; generic-message-command : - ;; string x number -> communicator x (number U string) -> list (string) +;; open-news-group : +;; communicator x string -> number x number x number - (define (generic-message-command command ok-code) - (lambda (communicator message-index) - (send-to-server communicator (string-append command " ~a") - (if (number? message-index) +;; -- The returned values are the number of articles, the first +;; article number, and the last article number for that group. + +(define (open-news-group communicator group-name) + (send-to-server communicator "GROUP ~a" group-name) + (let-values ([(code rest-of-line) + (get-single-line-response communicator)]) + (case code + [(211) + (let ([match (map string->number + (cdr + (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) + ((signal-error make-bad-newsgroup-line + "malformed newsgroup open response: ~s" + rest-of-line) + rest-of-line))))]) + (let ([number-of-articles (car match)] + [first-article-number (cadr match)] + [last-article-number (caddr match)]) + (values number-of-articles + first-article-number + last-article-number)))] + [(411) + ((signal-error make-non-existent-group + "group ~s does not exist on server ~s" + group-name (communicator-server communicator)) + group-name)] + [else + ((signal-error make-unexpected-response + "unexpected group opening response: ~s" code) + code rest-of-line)]))) + +;; generic-message-command : +;; string x number -> communicator x (number U string) -> list (string) + +(define (generic-message-command command ok-code) + (lambda (communicator message-index) + (send-to-server communicator (string-append command " ~a") + (if (number? message-index) (number->string message-index) message-index)) - (let-values ([(code response) - (get-single-line-response communicator)]) - (if (= code ok-code) + (let-values ([(code response) + (get-single-line-response communicator)]) + (if (= code ok-code) (get-rest-of-multi-line-response communicator) (case code [(423) @@ -265,54 +265,54 @@ "unexpected message access response: ~s" code) code response)]))))) - ;; head-of-message : - ;; communicator x (number U string) -> list (string) +;; head-of-message : +;; communicator x (number U string) -> list (string) - (define head-of-message - (generic-message-command "HEAD" 221)) +(define head-of-message + (generic-message-command "HEAD" 221)) - ;; body-of-message : - ;; communicator x (number U string) -> list (string) +;; body-of-message : +;; communicator x (number U string) -> list (string) - (define body-of-message - (generic-message-command "BODY" 222)) +(define body-of-message + (generic-message-command "BODY" 222)) - ;; newnews-since : - ;; communicator x (number U string) -> list (string) +;; newnews-since : +;; communicator x (number U string) -> list (string) - (define newnews-since - (generic-message-command "NEWNEWS" 230)) +(define newnews-since + (generic-message-command "NEWNEWS" 230)) - ;; make-desired-header : - ;; string -> desired +;; make-desired-header : +;; string -> desired - (define (make-desired-header raw-header) - (regexp - (string-append - "^" - (list->string - (apply append - (map (lambda (c) - (cond - [(char-lower-case? c) - (list #\[ (char-upcase c) c #\])] - [(char-upper-case? c) - (list #\[ c (char-downcase c) #\])] - [else - (list c)])) - (string->list raw-header)))) - ":"))) +(define (make-desired-header raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + [(char-lower-case? c) + (list #\[ (char-upcase c) c #\])] + [(char-upper-case? c) + (list #\[ c (char-downcase c) #\])] + [else + (list c)])) + (string->list raw-header)))) + ":"))) - ;; extract-desired-headers : - ;; list (string) x list (desired) -> list (string) +;; extract-desired-headers : +;; list (string) x list (desired) -> list (string) - (define (extract-desired-headers headers desireds) - (let loop ([headers headers]) - (if (null? headers) null - (let ([first (car headers)] - [rest (cdr headers)]) - (if (ormap (lambda (matcher) - (regexp-match matcher first)) - desireds) +(define (extract-desired-headers headers desireds) + (let loop ([headers headers]) + (if (null? headers) null + (let ([first (car headers)] + [rest (cdr headers)]) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) (cons first (loop rest)) (loop rest)))))) diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss index b68e873713..c4f06035cf 100644 --- a/collects/net/pop3-unit.ss +++ b/collects/net/pop3-unit.ss @@ -1,390 +1,390 @@ #lang scheme/unit - (require (lib "etc.ss") "pop3-sig.ss") +(require scheme/tcp "pop3-sig.ss") - (import) - (export pop3^) +(import) +(export pop3^) - ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose +;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose - ;; sender : oport - ;; receiver : iport - ;; server : string - ;; port : number - ;; state : symbol = (disconnected, authorization, transaction) +;; sender : oport +;; receiver : iport +;; server : string +;; port : number +;; state : symbol = (disconnected, authorization, transaction) - (define-struct communicator (sender receiver server port state)) +(define-struct communicator (sender receiver server port [state #:mutable])) - (define-struct (pop3 exn) ()) - (define-struct (cannot-connect pop3) ()) - (define-struct (username-rejected pop3) ()) - (define-struct (password-rejected pop3) ()) - (define-struct (not-ready-for-transaction pop3) (communicator)) - (define-struct (not-given-headers pop3) (communicator message)) - (define-struct (illegal-message-number pop3) (communicator message)) - (define-struct (cannot-delete-message exn) (communicator message)) - (define-struct (disconnect-not-quiet pop3) (communicator)) - (define-struct (malformed-server-response pop3) (communicator)) +(define-struct (pop3 exn) ()) +(define-struct (cannot-connect pop3) ()) +(define-struct (username-rejected pop3) ()) +(define-struct (password-rejected pop3) ()) +(define-struct (not-ready-for-transaction pop3) (communicator)) +(define-struct (not-given-headers pop3) (communicator message)) +(define-struct (illegal-message-number pop3) (communicator message)) +(define-struct (cannot-delete-message exn) (communicator message)) +(define-struct (disconnect-not-quiet pop3) (communicator)) +(define-struct (malformed-server-response pop3) (communicator)) - ;; signal-error : - ;; (exn-args ... -> exn) x format-string x values ... -> - ;; exn-args -> () +;; signal-error : +;; (exn-args ... -> exn) x format-string x values ... -> +;; exn-args -> () - (define (signal-error constructor format-string . args) - (lambda exn-args - (raise (apply constructor - (apply format format-string args) - (current-continuation-marks) - exn-args)))) +(define (signal-error constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (apply format format-string args) + (current-continuation-marks) + exn-args)))) - ;; signal-malformed-response-error : - ;; exn-args -> () +;; signal-malformed-response-error : +;; exn-args -> () - ;; -- in practice, it takes only one argument: a communicator. +;; -- in practice, it takes only one argument: a communicator. - (define signal-malformed-response-error - (signal-error make-malformed-server-response - "malformed response from server")) +(define signal-malformed-response-error + (signal-error make-malformed-server-response + "malformed response from server")) - ;; confirm-transaction-mode : - ;; communicator x string -> () +;; confirm-transaction-mode : +;; communicator x string -> () - ;; -- signals an error otherwise. +;; -- signals an error otherwise. - (define (confirm-transaction-mode communicator error-message) - (unless (eq? (communicator-state communicator) 'transaction) - ((signal-error make-not-ready-for-transaction error-message) - communicator))) +(define (confirm-transaction-mode communicator error-message) + (unless (eq? (communicator-state communicator) 'transaction) + ((signal-error make-not-ready-for-transaction error-message) + communicator))) - ;; default-pop-port-number : - ;; number +;; default-pop-port-number : +;; number - (define default-pop-port-number 110) +(define default-pop-port-number 110) - (define-struct server-responses ()) - (define-struct (+ok server-responses) ()) - (define-struct (-err server-responses) ()) +(define-struct server-responses ()) +(define-struct (+ok server-responses) ()) +(define-struct (-err server-responses) ()) - ;; connect-to-server*: - ;; input-port output-port -> communicator +;; connect-to-server*: +;; input-port output-port -> communicator - (define connect-to-server* - (case-lambda - [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")] - [(receiver sender server-name port-number) - (let ([communicator (make-communicator sender receiver server-name port-number - 'authorization)]) - (let ([response (get-status-response/basic communicator)]) - (cond - [(+ok? response) communicator] - [(-err? response) - ((signal-error make-cannot-connect - "cannot connect to ~a on port ~a" - server-name port-number))])))])) - - ;; connect-to-server : - ;; string [x number] -> communicator - - (define connect-to-server - (opt-lambda (server-name (port-number default-pop-port-number)) - (let-values ([(receiver sender) (tcp-connect server-name port-number)]) - (connect-to-server* receiver sender server-name port-number)))) - - ;; authenticate/plain-text : - ;; string x string x communicator -> () - - ;; -- if authentication succeeds, sets the communicator's state to - ;; transaction. - - (define (authenticate/plain-text username password communicator) - (let ([sender (communicator-sender communicator)]) - (send-to-server communicator "USER ~a" username) - (let ([status (get-status-response/basic communicator)]) +(define connect-to-server* + (case-lambda + [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")] + [(receiver sender server-name port-number) + (let ([communicator (make-communicator sender receiver server-name port-number + 'authorization)]) + (let ([response (get-status-response/basic communicator)]) (cond - [(+ok? status) - (send-to-server communicator "PASS ~a" password) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (set-communicator-state! communicator 'transaction)] - [(-err? status) - ((signal-error make-password-rejected - "password was rejected"))]))] - [(-err? status) - ((signal-error make-username-rejected - "username was rejected"))])))) + [(+ok? response) communicator] + [(-err? response) + ((signal-error make-cannot-connect + "cannot connect to ~a on port ~a" + server-name port-number))])))])) - ;; get-mailbox-status : - ;; communicator -> number x number +;; connect-to-server : +;; string [x number] -> communicator - ;; -- returns number of messages and number of octets. +(define connect-to-server + (lambda (server-name (port-number default-pop-port-number)) + (let-values ([(receiver sender) (tcp-connect server-name port-number)]) + (connect-to-server* receiver sender server-name port-number)))) - (define (get-mailbox-status communicator) - (confirm-transaction-mode - communicator - "cannot get mailbox status unless in transaction mode") - (send-to-server communicator "STAT") - (apply values - (map string->number - (let-values ([(status result) - (get-status-response/match - communicator - #rx"([0-9]+) ([0-9]+)" - #f)]) - result)))) +;; authenticate/plain-text : +;; string x string x communicator -> () - ;; get-message/complete : - ;; communicator x number -> list (string) x list (string) +;; -- if authentication succeeds, sets the communicator's state to +;; transaction. - (define (get-message/complete communicator message) - (confirm-transaction-mode - communicator - "cannot get message headers unless in transaction state") - (send-to-server communicator "RETR ~a" message) +(define (authenticate/plain-text username password communicator) + (let ([sender (communicator-sender communicator)]) + (send-to-server communicator "USER ~a" username) (let ([status (get-status-response/basic communicator)]) (cond - [(+ok? status) - (split-header/body (get-multi-line-response communicator))] - [(-err? status) - ((signal-error make-illegal-message-number - "not given message ~a" message) - communicator message)]))) + [(+ok? status) + (send-to-server communicator "PASS ~a" password) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (set-communicator-state! communicator 'transaction)] + [(-err? status) + ((signal-error make-password-rejected + "password was rejected"))]))] + [(-err? status) + ((signal-error make-username-rejected + "username was rejected"))])))) - ;; get-message/headers : - ;; communicator x number -> list (string) +;; get-mailbox-status : +;; communicator -> number x number - (define (get-message/headers communicator message) - (confirm-transaction-mode - communicator - "cannot get message headers unless in transaction state") - (send-to-server communicator "TOP ~a 0" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (let-values ([(headers body) - (split-header/body - (get-multi-line-response communicator))]) - headers)] - [(-err? status) - ((signal-error make-not-given-headers - "not given headers to message ~a" message) - communicator message)]))) +;; -- returns number of messages and number of octets. - ;; get-message/body : - ;; communicator x number -> list (string) +(define (get-mailbox-status communicator) + (confirm-transaction-mode + communicator + "cannot get mailbox status unless in transaction mode") + (send-to-server communicator "STAT") + (apply values + (map string->number + (let-values ([(status result) + (get-status-response/match + communicator + #rx"([0-9]+) ([0-9]+)" + #f)]) + result)))) - (define (get-message/body communicator message) - (let-values ([(headers body) (get-message/complete communicator message)]) - body)) +;; get-message/complete : +;; communicator x number -> list (string) x list (string) - ;; split-header/body : - ;; list (string) -> list (string) x list (string) +(define (get-message/complete communicator message) + (confirm-transaction-mode + communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "RETR ~a" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (split-header/body (get-multi-line-response communicator))] + [(-err? status) + ((signal-error make-illegal-message-number + "not given message ~a" message) + communicator message)]))) - ;; -- returns list of headers and list of body lines. +;; get-message/headers : +;; communicator x number -> list (string) - (define (split-header/body lines) - (let loop ([lines lines] [header null]) - (if (null? lines) +(define (get-message/headers communicator message) + (confirm-transaction-mode + communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "TOP ~a 0" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (let-values ([(headers body) + (split-header/body + (get-multi-line-response communicator))]) + headers)] + [(-err? status) + ((signal-error make-not-given-headers + "not given headers to message ~a" message) + communicator message)]))) + +;; get-message/body : +;; communicator x number -> list (string) + +(define (get-message/body communicator message) + (let-values ([(headers body) (get-message/complete communicator message)]) + body)) + +;; split-header/body : +;; list (string) -> list (string) x list (string) + +;; -- returns list of headers and list of body lines. + +(define (split-header/body lines) + (let loop ([lines lines] [header null]) + (if (null? lines) (values (reverse header) null) (let ([first (car lines)] [rest (cdr lines)]) (if (string=? first "") - (values (reverse header) rest) - (loop rest (cons first header))))))) + (values (reverse header) rest) + (loop rest (cons first header))))))) - ;; delete-message : - ;; communicator x number -> () +;; delete-message : +;; communicator x number -> () - (define (delete-message communicator message) - (confirm-transaction-mode - communicator - "cannot delete message unless in transaction state") - (send-to-server communicator "DELE ~a" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(-err? status) - ((signal-error make-cannot-delete-message - "no message numbered ~a available to be deleted" message) - communicator message)] - [(+ok? status) - 'deleted]))) +(define (delete-message communicator message) + (confirm-transaction-mode + communicator + "cannot delete message unless in transaction state") + (send-to-server communicator "DELE ~a" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(-err? status) + ((signal-error make-cannot-delete-message + "no message numbered ~a available to be deleted" message) + communicator message)] + [(+ok? status) + 'deleted]))) - ;; regexp for UIDL responses +;; regexp for UIDL responses - (define uidl-regexp #rx"([0-9]+) (.*)") +(define uidl-regexp #rx"([0-9]+) (.*)") - ;; get-unique-id/single : - ;; communicator x number -> string +;; get-unique-id/single : +;; communicator x number -> string - (define (get-unique-id/single communicator message) - (confirm-transaction-mode - communicator - "cannot get unique message id unless in transaction state") - (send-to-server communicator "UIDL ~a" message) - (let-values ([(status result) - (get-status-response/match communicator uidl-regexp ".*")]) - ;; The server response is of the form - ;; +OK 2 QhdPYR:00WBw1Ph7x7 - (cond - [(-err? status) - ((signal-error make-illegal-message-number - "no message numbered ~a available for unique id" message) - communicator message)] - [(+ok? status) - (cadr result)]))) +(define (get-unique-id/single communicator message) + (confirm-transaction-mode + communicator + "cannot get unique message id unless in transaction state") + (send-to-server communicator "UIDL ~a" message) + (let-values ([(status result) + (get-status-response/match communicator uidl-regexp ".*")]) + ;; The server response is of the form + ;; +OK 2 QhdPYR:00WBw1Ph7x7 + (cond + [(-err? status) + ((signal-error make-illegal-message-number + "no message numbered ~a available for unique id" message) + communicator message)] + [(+ok? status) + (cadr result)]))) - ;; get-unique-id/all : - ;; communicator -> list(number x string) +;; get-unique-id/all : +;; communicator -> list(number x string) - (define (get-unique-id/all communicator) - (confirm-transaction-mode communicator - "cannot get unique message ids unless in transaction state") - (send-to-server communicator "UIDL") - (let ([status (get-status-response/basic communicator)]) - ;; The server response is of the form - ;; +OK - ;; 1 whqtswO00WBw418f9t5JxYwZ - ;; 2 QhdPYR:00WBw1Ph7x7 - ;; . - (map (lambda (l) - (let ([m (regexp-match uidl-regexp l)]) - (cons (string->number (cadr m)) (caddr m)))) - (get-multi-line-response communicator)))) +(define (get-unique-id/all communicator) + (confirm-transaction-mode communicator + "cannot get unique message ids unless in transaction state") + (send-to-server communicator "UIDL") + (let ([status (get-status-response/basic communicator)]) + ;; The server response is of the form + ;; +OK + ;; 1 whqtswO00WBw418f9t5JxYwZ + ;; 2 QhdPYR:00WBw1Ph7x7 + ;; . + (map (lambda (l) + (let ([m (regexp-match uidl-regexp l)]) + (cons (string->number (cadr m)) (caddr m)))) + (get-multi-line-response communicator)))) - ;; close-communicator : - ;; communicator -> () +;; close-communicator : +;; communicator -> () - (define (close-communicator communicator) - (close-input-port (communicator-receiver communicator)) - (close-output-port (communicator-sender communicator))) +(define (close-communicator communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator))) - ;; disconnect-from-server : - ;; communicator -> () +;; disconnect-from-server : +;; communicator -> () - (define (disconnect-from-server communicator) - (send-to-server communicator "QUIT") - (set-communicator-state! communicator 'disconnected) - (let ([response (get-status-response/basic communicator)]) - (close-communicator communicator) - (cond - [(+ok? response) (void)] - [(-err? response) - ((signal-error make-disconnect-not-quiet - "got error status upon disconnect") - communicator)]))) +(define (disconnect-from-server communicator) + (send-to-server communicator "QUIT") + (set-communicator-state! communicator 'disconnected) + (let ([response (get-status-response/basic communicator)]) + (close-communicator communicator) + (cond + [(+ok? response) (void)] + [(-err? response) + ((signal-error make-disconnect-not-quiet + "got error status upon disconnect") + communicator)]))) - ;; send-to-server : - ;; communicator x format-string x list (values) -> () +;; send-to-server : +;; communicator x format-string x list (values) -> () - (define (send-to-server communicator message-template . rest) - (apply fprintf (communicator-sender communicator) - (string-append message-template "\r\n") - rest) - (flush-output (communicator-sender communicator))) +(define (send-to-server communicator message-template . rest) + (apply fprintf (communicator-sender communicator) + (string-append message-template "\r\n") + rest) + (flush-output (communicator-sender communicator))) - ;; get-one-line-from-server : - ;; iport -> string +;; get-one-line-from-server : +;; iport -> string - (define (get-one-line-from-server server->client-port) - (read-line server->client-port 'return-linefeed)) +(define (get-one-line-from-server server->client-port) + (read-line server->client-port 'return-linefeed)) - ;; get-server-status-response : - ;; communicator -> server-responses x string +;; get-server-status-response : +;; communicator -> server-responses x string - ;; -- provides the low-level functionality of checking for +OK - ;; and -ERR, returning an appropriate structure, and returning the - ;; rest of the status response as a string to be used for further - ;; parsing, if necessary. +;; -- provides the low-level functionality of checking for +OK +;; and -ERR, returning an appropriate structure, and returning the +;; rest of the status response as a string to be used for further +;; parsing, if necessary. - (define (get-server-status-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)] - [r (regexp-match #rx"^\\+OK(.*)" status-line)]) - (if r +(define (get-server-status-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)] + [r (regexp-match #rx"^\\+OK(.*)" status-line)]) + (if r (values (make-+ok) (cadr r)) (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) (if r - (values (make--err) (cadr r)) - (signal-malformed-response-error communicator)))))) + (values (make--err) (cadr r)) + (signal-malformed-response-error communicator)))))) - ;; get-status-response/basic : - ;; communicator -> server-responses +;; get-status-response/basic : +;; communicator -> server-responses - ;; -- when the only thing to determine is whether the response - ;; was +OK or -ERR. +;; -- when the only thing to determine is whether the response +;; was +OK or -ERR. - (define (get-status-response/basic communicator) - (let-values ([(response rest) - (get-server-status-response communicator)]) - response)) +(define (get-status-response/basic communicator) + (let-values ([(response rest) + (get-server-status-response communicator)]) + response)) - ;; get-status-response/match : - ;; communicator x regexp x regexp -> (status x list (string)) +;; get-status-response/match : +;; communicator x regexp x regexp -> (status x list (string)) - ;; -- when further parsing of the status response is necessary. - ;; Strips off the car of response from regexp-match. +;; -- when further parsing of the status response is necessary. +;; Strips off the car of response from regexp-match. - (define (get-status-response/match communicator +regexp -regexp) - (let-values ([(response rest) - (get-server-status-response communicator)]) - (if (and +regexp (+ok? response)) +(define (get-status-response/match communicator +regexp -regexp) + (let-values ([(response rest) + (get-server-status-response communicator)]) + (if (and +regexp (+ok? response)) (let ([r (regexp-match +regexp rest)]) (if r (values response (cdr r)) (signal-malformed-response-error communicator))) (if (and -regexp (-err? response)) - (let ([r (regexp-match -regexp rest)]) - (if r (values response (cdr r)) - (signal-malformed-response-error communicator))) - (signal-malformed-response-error communicator))))) + (let ([r (regexp-match -regexp rest)]) + (if r (values response (cdr r)) + (signal-malformed-response-error communicator))) + (signal-malformed-response-error communicator))))) - ;; get-multi-line-response : - ;; communicator -> list (string) +;; get-multi-line-response : +;; communicator -> list (string) - (define (get-multi-line-response communicator) - (let ([receiver (communicator-receiver communicator)]) - (let loop () - (let ([l (get-one-line-from-server receiver)]) - (cond - [(eof-object? l) - (signal-malformed-response-error communicator)] - [(string=? l ".") - '()] - [(and (> (string-length l) 1) - (char=? (string-ref l 0) #\.)) - (cons (substring l 1 (string-length l)) (loop))] - [else - (cons l (loop))]))))) +(define (get-multi-line-response communicator) + (let ([receiver (communicator-receiver communicator)]) + (let loop () + (let ([l (get-one-line-from-server receiver)]) + (cond + [(eof-object? l) + (signal-malformed-response-error communicator)] + [(string=? l ".") + '()] + [(and (> (string-length l) 1) + (char=? (string-ref l 0) #\.)) + (cons (substring l 1 (string-length l)) (loop))] + [else + (cons l (loop))]))))) - ;; make-desired-header : - ;; string -> desired +;; make-desired-header : +;; string -> desired - (define (make-desired-header raw-header) - (regexp - (string-append - "^" - (list->string - (apply append - (map (lambda (c) - (cond - [(char-lower-case? c) - (list #\[ (char-upcase c) c #\])] - [(char-upper-case? c) - (list #\[ c (char-downcase c) #\])] - [else - (list c)])) - (string->list raw-header)))) - ":"))) +(define (make-desired-header raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + [(char-lower-case? c) + (list #\[ (char-upcase c) c #\])] + [(char-upper-case? c) + (list #\[ c (char-downcase c) #\])] + [else + (list c)])) + (string->list raw-header)))) + ":"))) - ;; extract-desired-headers : - ;; list (string) x list (desired) -> list (string) +;; extract-desired-headers : +;; list (string) x list (desired) -> list (string) - (define (extract-desired-headers headers desireds) - (let loop ([headers headers]) - (if (null? headers) null - (let ([first (car headers)] - [rest (cdr headers)]) - (if (ormap (lambda (matcher) - (regexp-match matcher first)) - desireds) +(define (extract-desired-headers headers desireds) + (let loop ([headers headers]) + (if (null? headers) null + (let ([first (car headers)] + [rest (cdr headers)]) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) (cons first (loop rest)) (loop rest)))))) diff --git a/collects/net/qp-sig.ss b/collects/net/qp-sig.ss index b240760421..26a76e51e1 100644 --- a/collects/net/qp-sig.ss +++ b/collects/net/qp-sig.ss @@ -1,9 +1,9 @@ #lang scheme/signature ;; -- exceptions raised -- -(struct qp-error () -setters -constructor) -(struct qp-wrong-input () -setters -constructor) -(struct qp-wrong-line-size (size) -setters -constructor) +(struct qp-error () #:omit-constructor) +(struct qp-wrong-input () #:omit-constructor) +(struct qp-wrong-line-size (size) #:omit-constructor) ;; -- qp methods -- qp-encode diff --git a/collects/net/smtp-unit.ss b/collects/net/smtp-unit.ss index fc58f4ae2b..9c14319030 100644 --- a/collects/net/smtp-unit.ss +++ b/collects/net/smtp-unit.ss @@ -1,26 +1,27 @@ #lang scheme/unit - (require (lib "list.ss") (lib "kw.ss") "base64.ss" "smtp-sig.ss") - (import) - (export smtp^) +(require scheme/tcp "base64.ss" "smtp-sig.ss") - (define smtp-sending-server (make-parameter "localhost")) +(import) +(export smtp^) - (define debug-via-stdio? #f) +(define smtp-sending-server (make-parameter "localhost")) - (define (log . args) - ;; (apply printf args) - (void)) +(define debug-via-stdio? #f) - (define (starts-with? l n) - (and (>= (string-length l) (string-length n)) - (string=? n (substring l 0 (string-length n))))) +(define (log . args) + ;; (apply printf args) + (void)) - (define (check-reply/accum r v w a) - (flush-output w) - (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) - (log "server: ~a\n" l) - (if (eof-object? l) +(define (starts-with? l n) + (and (>= (string-length l) (string-length n)) + (string=? n (substring l 0 (string-length n))))) + +(define (check-reply/accum r v w a) + (flush-output w) + (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) + (log "server: ~a\n" l) + (if (eof-object? l) (error 'check-reply "got EOF") (let ([n (number->string v)]) (unless (starts-with? l n) @@ -32,135 +33,133 @@ ;; We're finished, so add the last and reverse the result (when a (reverse (cons (substring l 4) a))))))))) - - (define (check-reply/commands r v w . commands) - ;; drop the first response, which is just the flavor text -- we expect the rest to - ;; be a list of supported ESMTP commands. - (let ([cmdlist (rest (check-reply/accum r v w '()))]) - (for-each (lambda (c1) - (unless (findf (lambda (c2) (string=? c1 c2)) cmdlist) - (error "expected advertisement of ESMTP command ~a" c1))) - commands))) - - (define (check-reply r v w) - (check-reply/accum r v w #f)) - (define (protect-line l) - ;; If begins with a dot, add one more - (if (or (equal? l #"") - (equal? l "") - (and (string? l) - (not (char=? #\. (string-ref l 0)))) - (and (bytes? l) - (not (= (char->integer #\.) (bytes-ref l 0))))) +(define (check-reply/commands r v w . commands) + ;; drop the first response, which is just the flavor text -- we expect the rest to + ;; be a list of supported ESMTP commands. + (let ([cmdlist (cdr (check-reply/accum r v w '()))]) + (for-each (lambda (c1) + (unless (findf (lambda (c2) (string=? c1 c2)) cmdlist) + (error "expected advertisement of ESMTP command ~a" c1))) + commands))) + +(define (check-reply r v w) + (check-reply/accum r v w #f)) + +(define (protect-line l) + ;; If begins with a dot, add one more + (if (or (equal? l #"") + (equal? l "") + (and (string? l) + (not (char=? #\. (string-ref l 0)))) + (and (bytes? l) + (not (= (char->integer #\.) (bytes-ref l 0))))) l (if (bytes? l) - (bytes-append #"." l) - (string-append "." l)))) + (bytes-append #"." l) + (string-append "." l)))) - (define smtp-sending-end-of-message - (make-parameter void - (lambda (f) - (unless (and (procedure? f) - (procedure-arity-includes? f 0)) - (raise-type-error 'smtp-sending-end-of-message "thunk" f)) - f))) +(define smtp-sending-end-of-message + (make-parameter void + (lambda (f) + (unless (and (procedure? f) + (procedure-arity-includes? f 0)) + (raise-type-error 'smtp-sending-end-of-message "thunk" f)) + f))) - (define (smtp-send-message* r w sender recipients header message-lines - auth-user auth-passwd tls-encode) - (with-handlers ([void (lambda (x) - (close-input-port r) - (close-output-port w) - (raise x))]) +(define (smtp-send-message* r w sender recipients header message-lines + auth-user auth-passwd tls-encode) + (with-handlers ([void (lambda (x) + (close-input-port r) + (close-output-port w) + (raise x))]) + (check-reply r 220 w) + (log "hello\n") + (fprintf w "EHLO ~a\r\n" (smtp-sending-server)) + (when tls-encode + (check-reply/commands r 250 w "STARTTLS") + (log "starttls\n") + (fprintf w "STARTTLS\r\n") (check-reply r 220 w) - (log "hello\n") - (fprintf w "EHLO ~a\r\n" (smtp-sending-server)) - (when tls-encode - (check-reply/commands r 250 w "STARTTLS") - (log "starttls\n") - (fprintf w "STARTTLS\r\n") - (check-reply r 220 w) - (let-values ([(ssl-r ssl-w) - (tls-encode r w - #:mode 'connect - #:encrypt 'tls - #:close-original? #t)]) - (set! r ssl-r) - (set! w ssl-w)) - ;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO. - (log "tls hello\n") - (fprintf w "EHLO ~a\r\n" (smtp-sending-server))) - (check-reply r 250 w) + (let-values ([(ssl-r ssl-w) + (tls-encode r w + #:mode 'connect + #:encrypt 'tls + #:close-original? #t)]) + (set! r ssl-r) + (set! w ssl-w)) + ;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO. + (log "tls hello\n") + (fprintf w "EHLO ~a\r\n" (smtp-sending-server))) + (check-reply r 250 w) - (when auth-user - (log "auth\n") - (fprintf w "AUTH PLAIN ~a" - ;; Encoding adds CRLF - (base64-encode - (string->bytes/latin-1 - (format "~a\0~a\0~a" auth-user auth-user auth-passwd)))) - (check-reply r 235 w)) + (when auth-user + (log "auth\n") + (fprintf w "AUTH PLAIN ~a" + ;; Encoding adds CRLF + (base64-encode + (string->bytes/latin-1 + (format "~a\0~a\0~a" auth-user auth-user auth-passwd)))) + (check-reply r 235 w)) - (log "from\n") - (fprintf w "MAIL FROM:<~a>\r\n" sender) - (check-reply r 250 w) + (log "from\n") + (fprintf w "MAIL FROM:<~a>\r\n" sender) + (check-reply r 250 w) - (log "to\n") - (for-each - (lambda (dest) - (fprintf w "RCPT TO:<~a>\r\n" dest) - (check-reply r 250 w)) - recipients) + (log "to\n") + (for-each + (lambda (dest) + (fprintf w "RCPT TO:<~a>\r\n" dest) + (check-reply r 250 w)) + recipients) - (log "header\n") - (fprintf w "DATA\r\n") - (check-reply r 354 w) - (fprintf w "~a" header) - (for-each - (lambda (l) - (log "body: ~a\n" l) - (fprintf w "~a\r\n" (protect-line l))) - message-lines) + (log "header\n") + (fprintf w "DATA\r\n") + (check-reply r 354 w) + (fprintf w "~a" header) + (for-each + (lambda (l) + (log "body: ~a\n" l) + (fprintf w "~a\r\n" (protect-line l))) + message-lines) - ;; After we send the ".", then only break in an emergency - ((smtp-sending-end-of-message)) + ;; After we send the ".", then only break in an emergency + ((smtp-sending-end-of-message)) - (log "dot\n") - (fprintf w ".\r\n") - (flush-output w) - (check-reply r 250 w) + (log "dot\n") + (fprintf w ".\r\n") + (flush-output w) + (check-reply r 250 w) - ;; Once a 250 has been received in response to the . at the end of - ;; the DATA block, the email has been sent successfully and out of our - ;; hands. This function should thus indicate success at this point - ;; no matter what else happens. - ;; - ;; Some servers (like smtp.gmail.com) will just close the connection - ;; on a QUIT, so instead of causing any QUIT errors to look like the - ;; email failed, we'll just log them. - (with-handlers ([void (lambda (x) - (log "error after send: ~a\n" (exn-message x)))]) - (log "quit\n") - (fprintf w "QUIT\r\n") - (check-reply r 221 w)) + ;; Once a 250 has been received in response to the . at the end of + ;; the DATA block, the email has been sent successfully and out of our + ;; hands. This function should thus indicate success at this point + ;; no matter what else happens. + ;; + ;; Some servers (like smtp.gmail.com) will just close the connection + ;; on a QUIT, so instead of causing any QUIT errors to look like the + ;; email failed, we'll just log them. + (with-handlers ([void (lambda (x) + (log "error after send: ~a\n" (exn-message x)))]) + (log "quit\n") + (fprintf w "QUIT\r\n") + (check-reply r 221 w)) - (close-output-port w) - (close-input-port r))) + (close-output-port w) + (close-input-port r))) - (define smtp-send-message - (lambda/kw (server sender recipients header message-lines - #:key - [port-no 25] - [auth-user #f] - [auth-passwd #f] - [tcp-connect tcp-connect] - [tls-encode #f] - #:body - (#:optional [opt-port-no port-no])) - (when (null? recipients) - (error 'send-smtp-message "no receivers")) - (let-values ([(r w) (if debug-via-stdio? - (values (current-input-port) (current-output-port)) - (tcp-connect server opt-port-no))]) - (smtp-send-message* r w sender recipients header message-lines - auth-user auth-passwd tls-encode)))) +(define smtp-send-message + (lambda (server sender recipients header message-lines + #:port-no [port-no 25] + #:auth-user [auth-user #f] + #:auth-passwd [auth-passwd #f] + #:tcp-connect [tcp-connect tcp-connect] + #:tls-encode [tls-encode #f] + [opt-port-no port-no]) + (when (null? recipients) + (error 'send-smtp-message "no receivers")) + (let-values ([(r w) (if debug-via-stdio? + (values (current-input-port) (current-output-port)) + (tcp-connect server opt-port-no))]) + (smtp-send-message* r w sender recipients header message-lines + auth-user auth-passwd tls-encode)))) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index f542fce7ea..631ea7094e 100644 --- a/collects/scheme/list.ss +++ b/collects/scheme/list.ss @@ -46,14 +46,6 @@ (raise-type-error 'rest "non-empty list" x)) (cdr x)) - (define (last-pair l) - (if (pair? l) - (let loop ([l l] [x (cdr l)]) - (if (pair? x) - (loop x (cdr x)) - l)) - (raise-type-error 'last-pair "pair" l))) - (define cons? (lambda (x) (pair? x))) (define empty? (lambda (x) (null? x))) (define empty '())) diff --git a/collects/scheme/private/reqprov.ss b/collects/scheme/private/reqprov.ss index b0c8b8cb4f..ec2b486120 100644 --- a/collects/scheme/private/reqprov.ss +++ b/collects/scheme/private/reqprov.ss @@ -164,7 +164,7 @@ [else (error "huh?" mode)]))] [simple-path? (lambda (p) (syntax-case p (lib) - [(lib s) + [(lib . _) (check-lib-form p)] [_ (or (identifier? p) @@ -211,14 +211,14 @@ (and (simple-path? #'path) ;; check that it's well-formed... (call-with-values (lambda () (expand-import in)) - (lambda (a b) #t)) - (list (mode-wrap - base-mode - (datum->syntax - #'path - (syntax-e - (quasisyntax/loc in - (all-except path id ...)))))))] + (lambda (a b) #t))) + (list (mode-wrap + base-mode + (datum->syntax + #'path + (syntax-e + (quasisyntax/loc in + (all-except path id ...))))))] ;; General case: [_ (let-values ([(imports sources) (expand-import in)]) ;; TODO: collapse back to simple cases when possible diff --git a/collects/scheme/signature/info.ss b/collects/scheme/signature/info.ss new file mode 100644 index 0000000000..133ad94082 --- /dev/null +++ b/collects/scheme/signature/info.ss @@ -0,0 +1,2 @@ +(module info setup/infotab + (define name "Scheme signature language")) diff --git a/collects/scheme/signature/lang.ss b/collects/scheme/signature/lang.ss new file mode 100644 index 0000000000..9017e518d2 --- /dev/null +++ b/collects/scheme/signature/lang.ss @@ -0,0 +1,31 @@ +#lang scheme/base + +(require scheme/unit + (for-syntax scheme/base + mzlib/private/unit-compiletime + mzlib/private/unit-syntax)) + +(provide (rename-out [module-begin #%module-begin]) + (except-out (all-from-out scheme/base) #%module-begin) + (all-from-out scheme/unit) + (for-syntax (all-from-out scheme/base))) + +(define-for-syntax (make-name s) + (string->symbol + (string-append (regexp-replace "-sig$" (symbol->string s) "") + "^"))) + +(define-syntax (module-begin stx) + (parameterize ((error-syntax stx)) + (with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name)))) + (syntax-case stx () + ((_ . x) + (with-syntax ((((reqs ...) . (body ...)) + (split-requires (checked-syntax->list #'x)))) + (datum->syntax + stx + (syntax-e #'(#%module-begin + reqs ... + (provide name) + (define-signature name (body ...)))) + stx))))))) diff --git a/collects/scheme/signature/lang/reader.ss b/collects/scheme/signature/lang/reader.ss index d163138d8e..a57d1dfa20 100644 --- a/collects/scheme/signature/lang/reader.ss +++ b/collects/scheme/signature/lang/reader.ss @@ -1,3 +1,3 @@ (module reader syntax/module-reader - mzlib/a-signature) + scheme/signature/lang) diff --git a/collects/scheme/unit.ss b/collects/scheme/unit.ss index 12953eb41f..8e56ce4ebf 100644 --- a/collects/scheme/unit.ss +++ b/collects/scheme/unit.ss @@ -1,4 +1,104 @@ (module unit scheme/base - (require mzlib/unit) - (provide (all-from-out mzlib/unit))) + (require mzlib/unit + (for-syntax scheme/base + syntax/struct)) + (provide (except-out (all-from-out mzlib/unit) + struct) + (rename-out [struct* struct])) + + ;; Replacement `struct' signature form: + (define-signature-form (struct* stx) + (syntax-case stx () + ((_ name (field ...) opt ...) + (let ([omit-selectors #f] + [omit-setters #f] + [omit-constructor #f] + [omit-type #f]) + (unless (identifier? #'name) + (raise-syntax-error #f + "expected an identifier to name the structure type" + stx + #'name)) + (for-each (lambda (field) + (unless (identifier? field) + (syntax-case field () + [(id #:mutable) + (identifier? #'id) + 'ok] + [_ + (raise-syntax-error #f + "bad field specification" + stx + field)]))) + (syntax->list #'(field ...))) + (let-values ([(no-ctr? mutable? no-stx? no-rt?) + (let loop ([opts (syntax->list #'(opt ...))] + [no-ctr? #f] + [mutable? #f] + [no-stx? #f] + [no-rt? #f]) + (if (null? opts) + (values no-ctr? mutable? no-stx? no-rt?) + (let ([opt (car opts)]) + (case (syntax-e opt) + [(#:omit-constructor) + (if no-ctr? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) #t mutable? no-stx? no-rt?))] + [(#:mutable) + (if mutable? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? #t no-stx? no-rt?))] + [(#:omit-define-syntaxes) + (if no-stx? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? #t no-rt?))] + [(#:omit-define-values) + (if no-rt? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? no-stx? #t))] + [else + (raise-syntax-error #f + (string-append + "expected a keyword to specify option: " + "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") + stx + opt)]))))]) + (cons + #`(define-syntaxes (name) + #,(build-struct-expand-info + #'name (syntax->list #'(field ...)) + #f (not mutable?) + #f '(#f) '(#f) + #:omit-constructor? no-ctr?)) + (let ([names (build-struct-names #'name (syntax->list #'(field ...)) + #f (not mutable?))]) + (if no-ctr? + (cons (car names) (cddr names)) + names)))))) + ((_ name fields opt ...) + (raise-syntax-error #f + "bad syntax; expected a parenthesized sequence of fields" + stx + #'fields)) + ((_ name) + (raise-syntax-error #f + "bad syntax; missing fields" + stx)) + ((_) + (raise-syntax-error #f + "missing name and fields" + stx))))) diff --git a/collects/scheme/unit/info.ss b/collects/scheme/unit/info.ss new file mode 100644 index 0000000000..44576632a0 --- /dev/null +++ b/collects/scheme/unit/info.ss @@ -0,0 +1,2 @@ +(module info setup/infotab + (define name "Scheme unit language")) diff --git a/collects/scheme/unit/lang.ss b/collects/scheme/unit/lang.ss new file mode 100644 index 0000000000..fd64d43c25 --- /dev/null +++ b/collects/scheme/unit/lang.ss @@ -0,0 +1,84 @@ +#lang scheme/base + +(require scheme/unit + (for-syntax scheme/base + syntax/kerncase)) + +(provide (rename-out [module-begin #%module-begin]) + (except-out (all-from-out scheme/base) #%module-begin) + (all-from-out scheme/unit)) + +(define-for-syntax (make-name s) + (string->symbol + (string-append (regexp-replace "-unit$" (symbol->string s) "") + "@"))) + +;; Look for `import' and `export', and start processing the body: +(define-syntax (module-begin stx) + (syntax-case stx () + [(_ elem ...) + (with-syntax ([((elem ...) . (literal ...)) + (let loop ([elems (syntax->list #'(elem ...))] + [accum null]) + (syntax-case elems (import export) + [((import . _1) (export . _2) . _3) + (cons (reverse accum) elems)] + [((import . _1) . _2) + (raise-syntax-error + #f + "expected an `export' clause after `import'" + stx)] + [() + (raise-syntax-error + #f + "missing an `import' clause" + stx)] + [_else + (loop (cdr elems) (cons (car elems) accum))]))]) + (with-syntax ((name (datum->syntax + stx + (make-name (syntax-property stx 'enclosing-module-name)) + stx)) + (orig-stx stx)) + (datum->syntax + stx + (syntax-e + #'(#%module-begin (a-unit-module orig-stx finish-a-unit (import export) + "original import form" + name (elem ...) (literal ...)))) + stx + stx)))])) + +;; Process one `require' form (and make sure it's a require form): +(define-syntax (a-unit-module stx) + (syntax-case stx () + [(_ orig-stx finish stops separator name (elem1 elem ...) (literal ...)) + (let ([e (local-expand #'elem1 + 'module + (append + (syntax->list #'stops) + (list #'#%require) + (kernel-form-identifier-list)))]) + (syntax-case e (begin #%require) + [(#%require r ...) + #'(begin + (#%require r ...) + (a-unit-module orig-stx finish stops separator name (elem ...) (literal ...)))] + [(begin b ...) + #'(a-unit-module orig-stx finish stops separator name (b ... elem ...) (literal ...))] + [_ + (raise-syntax-error + #f + (format "non-require form before ~a" (syntax-e #'separator)) + #'orig-stx + e)]))] + [(_ orig-stx finish stops separator name () (literal ...)) + #'(finish orig-stx name literal ...)])) + +;; All requires are done, so finish handling the unit: +(define-syntax (finish-a-unit stx) + (syntax-case stx (import export) + [(_ orig-stx name imports exports elem ...) + #'(begin + (provide name) + (define-unit name imports exports elem ...))])) diff --git a/collects/scheme/unit/lang/reader.ss b/collects/scheme/unit/lang/reader.ss index dc8541bdcf..d8157c8a3c 100644 --- a/collects/scheme/unit/lang/reader.ss +++ b/collects/scheme/unit/lang/reader.ss @@ -1,3 +1,2 @@ (module reader syntax/module-reader - mzlib/a-unit) - + scheme/unit/lang) diff --git a/collects/scribblings/reference/reference.scrbl b/collects/scribblings/reference/reference.scrbl index 457596a932..e56e93f76b 100644 --- a/collects/scribblings/reference/reference.scrbl +++ b/collects/scribblings/reference/reference.scrbl @@ -24,6 +24,7 @@ language. @include-section["class.scrbl"] @include-section["units.scrbl"] @include-section["contracts.scrbl"] +@include-section["match.scrbl"] @include-section["control.scrbl"] @include-section["concurrency.scrbl"] @include-section["macros.scrbl"] diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index 96c4ac50f7..9dd05e7482 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -593,28 +593,20 @@ declarations; @scheme[define-signature] has no splicing @scheme[begin] form.)} @defform/subs[ -#:literals (-type -selectors -setters -constructor) -(struct id (field-id ...) omit-decl ...) +(struct id (field ...) option ...) -([omit-decl - -type - -selectors - -setters - -constructor])]{ +([field id + [id #:mutable]] + [option #:mutable + #:omit-constructor + #:omit-define-syntaxes + #:omit-define-values])]{ For use with @scheme[define-signature]. The expansion of a @scheme[struct] signature form includes all of the identifiers that -would be bound by @scheme[(define-struct id (field-id ...))], except -that a @scheme[omit-decl] can cause some of the bindings to be -omitted. Specifically @scheme[-type] causes -@schemeidfont{struct:}@scheme[id] to be omitted, @scheme[-selectors] -causes all @scheme[id]@schemeidfont{-}@scheme[_field-id]s to be -omitted, @scheme[-setters] causes all -@schemeidfont{set-}@scheme[id]@schemeidfont{-}@scheme[field-id]@schemeidfont{!}s -to be omitted, and @scheme[-construct] causes -@schemeidfont{make-}@scheme[id] to be omitted. These omissions are -reflected in the static information bound to @scheme[id] (which is -used by, for example, pattern matchers).} +would be bound by @scheme[(define-struct id (field ...) option ...)], +where the extra option @scheme[#:omit-constructor] omits the +@schemeidfont{make-}@scheme[id] identifier.} @; ------------------------------------------------------------------------ diff --git a/collects/scribblings/slideshow/guide.scrbl b/collects/scribblings/slideshow/guide.scrbl index b0174c2506..f4e35dcbc1 100644 --- a/collects/scribblings/slideshow/guide.scrbl +++ b/collects/scribblings/slideshow/guide.scrbl @@ -181,7 +181,7 @@ slideshow @; ------------------------------------------------------------------------ -@section{Display Size and Fonts} +@section[#:tag "display-size"]{Display Size and Fonts} Slideshow is configured for generating slides in @math{1024} by @math{768} pixel format. When the current display has a different diff --git a/collects/sirmail/sendr.ss b/collects/sirmail/sendr.ss index f3d20be52d..ea9380500a 100644 --- a/collects/sirmail/sendr.ss +++ b/collects/sirmail/sendr.ss @@ -2,15 +2,14 @@ ;; This module implements the mail-composing window. The `new-mailer' ;; function creates a compose-window instance. -(module sendr mzscheme - (require (lib "unit.ss") - (lib "class.ss") +(module sendr scheme/base + (require scheme/tcp + scheme/unit + scheme/class (lib "mred-sig.ss" "mred") (lib "framework.ss" "framework")) - (require (lib "list.ss") - (lib "file.ss") - (lib "string.ss") + (require scheme/file (lib "process.ss") (lib "mzssl.ss" "openssl")) @@ -126,7 +125,8 @@ (define-struct enclosure (name ; identifies enclosure in the GUI subheader ; header for enclosure - data-thunk)) ; gets enclosure data as bytes (already encoded) + data-thunk) ; gets enclosure data as bytes (already encoded) + #:mutable) ;; Create a message with enclosures. ;; `header' is a message header created with the head.ss library diff --git a/collects/syntax/path-spec.ss b/collects/syntax/path-spec.ss index 7aba18ffd6..8fcf1826b1 100644 --- a/collects/syntax/path-spec.ss +++ b/collects/syntax/path-spec.ss @@ -1,4 +1,5 @@ -(module path-spec mzscheme +(module path-spec scheme/base + (require (for-template scheme/base)) (require "stx.ss") (provide resolve-path-spec) @@ -19,7 +20,7 @@ (string->path s))] [(-build-path elem ...) (module-or-top-identifier=? #'-build-path build-path-stx) - (let ([l (syntax-object->datum (syntax (elem ...)))]) + (let ([l (syntax->datum (syntax (elem ...)))]) (when (null? l) (raise-syntax-error #f @@ -28,7 +29,7 @@ fn)) (apply build-path l))] [(lib filename ...) - (let ([l (syntax-object->datum (syntax (filename ...)))]) + (let ([l (syntax->datum (syntax (filename ...)))]) (unless (or (andmap string? l) (pair? l)) (raise-syntax-error diff --git a/collects/syntax/struct.ss b/collects/syntax/struct.ss index ca055495af..07eb7afbe2 100644 --- a/collects/syntax/struct.ss +++ b/collects/syntax/struct.ss @@ -1,14 +1,16 @@ -(module struct mzscheme - (require (lib "etc.ss") +(module struct scheme/base + (require (for-syntax scheme/base) + (lib "etc.ss") (lib "contract.ss") "stx.ss" (lib "struct-info.ss" "scheme")) - (require-for-template mzscheme) + (require (for-template mzscheme)) (provide parse-define-struct build-struct-generation + build-struct-generation* build-struct-expand-info struct-declaration-info? extract-struct-info @@ -96,7 +98,7 @@ [fields (map symbol->string (map syntax-e fields))] [+ string-append]) (map (lambda (s) - (datum->syntax-object name-stx (string->symbol s) srcloc-stx)) + (datum->syntax name-stx (string->symbol s) srcloc-stx)) (append (list (+ "struct:" name) @@ -155,8 +157,14 @@ ,@acc/mut-makers))))) (define build-struct-expand-info - (lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters) - (let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)]) + (lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters + #:omit-constructor? [no-ctr? #f]) + (let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)] + [names (if no-ctr? + (list* (car names) + #f + (cddr names)) + names)]) (build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters)))) (define build-struct-expand-info* diff --git a/collects/syntax/zodiac-sig.ss b/collects/syntax/zodiac-sig.ss index b8a794f7b8..fdcd770881 100644 --- a/collects/syntax/zodiac-sig.ss +++ b/collects/syntax/zodiac-sig.ss @@ -30,7 +30,7 @@ eof? ;; zodiac struct: ;; zodiac (stx) ; used to be (origin start finish) -(struct zodiac (stx)) +(struct zodiac (stx) #:mutable) zodiac-origin ; = identity zodiac-start ; = identity zodiac-finish ; = zodiac-start @@ -40,70 +40,70 @@ zodiac-finish ; = zodiac-start ;; zread ; used to have (object) ;; The sub-tree has been cut off; inspect ;; the stx object, instead. -(struct zread ()) +(struct zread () #:mutable) ;; elaborator structs: -(struct parsed (back)) +(struct parsed (back) #:mutable) -(struct varref (var)) -(struct top-level-varref (module slot exptime? expdef? position)) ; added module, exptime?, position +(struct varref (var) #:mutable) +(struct top-level-varref (module slot exptime? expdef? position) #:mutable) ; added module, exptime?, position create-top-level-varref -(struct bound-varref (binding)) create-bound-varref +(struct bound-varref (binding) #:mutable) create-bound-varref -(struct binding (var orig-name)) create-binding +(struct binding (var orig-name) #:mutable) create-binding make-lexical-varref lexical-varref? create-lexical-varref ; alias for bound-varref make-lexical-binding lexical-binding? create-lexical-binding ; alias for binding -(struct app (fun args)) create-app +(struct app (fun args) #:mutable) create-app -(struct if-form (test then else)) create-if-form -(struct quote-form (expr)) create-quote-form -(struct begin-form (bodies)) create-begin-form -(struct begin0-form (bodies)) create-begin0-form -(struct let-values-form (vars vals body)) create-let-values-form -(struct letrec-values-form (vars vals body)) create-letrec-values-form -(struct define-values-form (vars val)) create-define-values-form -(struct set!-form (var val)) create-set!-form -(struct case-lambda-form (args bodies)) create-case-lambda-form -(struct with-continuation-mark-form (key val body)) create-with-continuation-mark-form +(struct if-form (test then else) #:mutable) create-if-form +(struct quote-form (expr) #:mutable) create-quote-form +(struct begin-form (bodies) #:mutable) create-begin-form +(struct begin0-form (bodies) #:mutable) create-begin0-form +(struct let-values-form (vars vals body) #:mutable) create-let-values-form +(struct letrec-values-form (vars vals body) #:mutable) create-letrec-values-form +(struct define-values-form (vars val) #:mutable) create-define-values-form +(struct set!-form (var val) #:mutable) create-set!-form +(struct case-lambda-form (args bodies) #:mutable) create-case-lambda-form +(struct with-continuation-mark-form (key val body) #:mutable) create-with-continuation-mark-form ;; Thess are new: -(struct quote-syntax-form (expr)) create-quote-syntax-form -(struct define-syntaxes-form (names expr)) create-define-syntaxes-form -(struct define-for-syntax-form (names expr)) create-define-for-syntax-form +(struct quote-syntax-form (expr) #:mutable) create-quote-syntax-form +(struct define-syntaxes-form (names expr) #:mutable) create-define-syntaxes-form +(struct define-for-syntax-form (names expr) #:mutable) create-define-for-syntax-form (struct module-form (name requires ; lstof stx for module paths for-syntax-requires ; lstof stx for module paths for-template-requires ; lstof stx for module paths body ; begin form syntax-body ; begin form - provides ; lstof (sym | (def-sym . prvd-sym) | (mod-path def-sym . prvd-sym)) + provides ; lstof (sym | (def-sym . prvd-sym) #:mutable | (mod-path def-sym . prvd-sym)) syntax-provides ; ditto indirect-provides ; lstof sym kernel-reprovide-hint ; #f | #t | exclude-sym self-path-index)) ; module path index create-module-form -(struct require/provide-form ()) create-require/provide-form +(struct require/provide-form () #:mutable) create-require/provide-form ;; These forms are highly mzc-specific. They are recongized ;; as applications of the corresponding quoted symbols to the ;; right kinds of arguments. -(struct global-prepare (vec pos)) create-global-prepare -(struct global-lookup (vec pos)) create-global-lookup -(struct global-assign (vec pos expr)) create-global-assign -(struct safe-vector-ref (vec pos)) create-safe-vector-ref +(struct global-prepare (vec pos) #:mutable) create-global-prepare +(struct global-lookup (vec pos) #:mutable) create-global-lookup +(struct global-assign (vec pos expr) #:mutable) create-global-assign +(struct safe-vector-ref (vec pos) #:mutable) create-safe-vector-ref global-prepare-id global-lookup-id global-assign-id safe-vector-ref-id ;; args: -(struct arglist (vars)) -(struct sym-arglist ()) -(struct list-arglist ()) -(struct ilist-arglist ()) +(struct arglist (vars) #:mutable) +(struct sym-arglist () #:mutable) +(struct list-arglist () #:mutable) +(struct ilist-arglist () #:mutable) make-empty-back-box register-client diff --git a/collects/syntax/zodiac-unit.ss b/collects/syntax/zodiac-unit.ss index 5f6676e661..6494215465 100644 --- a/collects/syntax/zodiac-unit.ss +++ b/collects/syntax/zodiac-unit.ss @@ -4,768 +4,759 @@ #lang scheme/unit - (require (lib "unit.ss") - (lib "list.ss") - "kerncase.ss" - "zodiac-sig.ss" - "stx.ss") +(require "kerncase.ss" + "zodiac-sig.ss" + "stx.ss") - (import) - (export zodiac^) - - (define (stx-bound-assq ssym l) - (ormap (lambda (p) - (and (bound-identifier=? ssym (car p)) - p)) - l)) +(import) +(export zodiac^) - (define global-prepare-id (gensym)) - (define global-lookup-id (gensym)) - (define global-assign-id (gensym)) - (define safe-vector-ref-id (gensym)) +(define (stx-bound-assq ssym l) + (ormap (lambda (p) + (and (bound-identifier=? ssym (car p)) + p)) + l)) - ;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define global-prepare-id (gensym)) +(define global-lookup-id (gensym)) +(define global-assign-id (gensym)) +(define safe-vector-ref-id (gensym)) - (define-struct secure-box (value)) +;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define init-value-list '()) +(define-struct secure-box (value) #:mutable) - (define register-initial-value - (lambda (index value-thunk) - (set! init-value-list - (append init-value-list - (list value-thunk))))) +(define init-value-list '()) - (define make-initial-value-vector - (lambda () - (let ((v (make-vector current-vector-size uninitialized-flag))) - (let loop ((index 0) (inits init-value-list)) - (unless (null? inits) - (vector-set! v index ((car inits))) - (loop (add1 index) (cdr inits)))) - v))) +(define register-initial-value + (lambda (index value-thunk) + (set! init-value-list + (append init-value-list + (list value-thunk))))) - (define make-empty-back-box - (lambda () - (make-secure-box (make-initial-value-vector)))) +(define make-initial-value-vector + (lambda () + (let ((v (make-vector current-vector-size uninitialized-flag))) + (let loop ((index 0) (inits init-value-list)) + (unless (null? inits) + (vector-set! v index ((car inits))) + (loop (add1 index) (cdr inits)))) + v))) - (define current-vector-size 2) - - (define next-client-count - (let ((count -1)) - (lambda () - (set! count (add1 count)) - (when (>= count current-vector-size) - (set! current-vector-size (* 2 current-vector-size))) - count))) +(define make-empty-back-box + (lambda () + (make-secure-box (make-initial-value-vector)))) + +(define current-vector-size 2) + +(define next-client-count + (let ((count -1)) + (lambda () + (set! count (add1 count)) + (when (>= count current-vector-size) + (set! current-vector-size (* 2 current-vector-size))) + count))) + +(define-struct uninitialized-back ()) +(define uninitialized-flag (make-uninitialized-back)) + +(define getters-setters + (lambda (index) + (values + (lambda (back) ; getter + (let ((v (secure-box-value back))) + (with-handlers + ((exn:fail:contract? + (lambda (exception) + (vector-ref (extend-back-vector back) index)))) + (let ((value (vector-ref v index))) + (if (uninitialized-back? value) + (let ((correct-value + ((list-ref init-value-list index)))) + (vector-set! v index correct-value) + correct-value) + value))))) + (lambda (back value) ; setter + (let ((v (secure-box-value back))) + (with-handlers + ((exn:fail:contract? + (lambda (exception) + (vector-set! (extend-back-vector back) index value)))) + (vector-set! v index value))))))) + +(define register-client + (lambda (client-name default-initial-value-thunk) + (let ((index (next-client-count))) + (register-initial-value index default-initial-value-thunk) + (getters-setters index)))) + +(define extend-back-vector + (lambda (back-box) + (let ((v (secure-box-value back-box))) + (let ((new-v (make-initial-value-vector))) + (let loop ((n (sub1 (vector-length v)))) + (when (>= n 0) + (vector-set! new-v n (vector-ref v n)) + (loop (sub1 n)))) + (set-secure-box-value! back-box new-v) + new-v)))) - (define-struct uninitialized-back ()) - (define uninitialized-flag (make-uninitialized-back)) - - (define getters-setters - (lambda (index) - (values - (lambda (back) ; getter - (let ((v (secure-box-value back))) - (with-handlers - ((exn:fail:contract? - (lambda (exception) - (vector-ref (extend-back-vector back) index)))) - (let ((value (vector-ref v index))) - (if (uninitialized-back? value) - (let ((correct-value - ((list-ref init-value-list index)))) - (vector-set! v index correct-value) - correct-value) - value))))) - (lambda (back value) ; setter - (let ((v (secure-box-value back))) - (with-handlers - ((exn:fail:contract? - (lambda (exception) - (vector-set! (extend-back-vector back) index value)))) - (vector-set! v index value))))))) - - (define register-client - (lambda (client-name default-initial-value-thunk) - (let ((index (next-client-count))) - (register-initial-value index default-initial-value-thunk) - (getters-setters index)))) - - (define extend-back-vector - (lambda (back-box) - (let ((v (secure-box-value back-box))) - (let ((new-v (make-initial-value-vector))) - (let loop ((n (sub1 (vector-length v)))) - (when (>= n 0) - (vector-set! new-v n (vector-ref v n)) - (loop (sub1 n)))) - (set-secure-box-value! back-box new-v) - new-v)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define (mk-back) (make-empty-back-box)) +(define (mk-back) (make-empty-back-box)) - (define (get-slot stx table) - (let ([l (hash-table-get table (syntax-e stx) (lambda () null))]) - (let ([s (ormap (lambda (b) - (and (module-identifier=? stx (car b)) - (cdr b))) - l)]) - (if s - s - (let ([s (box #f)]) - (hash-table-put! table (syntax-e stx) (cons (cons stx s) l)) - s))))) +(define (get-slot stx table) + (let ([l (hash-table-get table (syntax-e stx) (lambda () null))]) + (let ([s (ormap (lambda (b) + (and (free-identifier=? stx (car b)) + (cdr b))) + l)]) + (if s + s + (let ([s (box #f)]) + (hash-table-put! table (syntax-e stx) (cons (cons stx s) l)) + s))))) - (define (let-s->z mk-let rec? stx env loop) - (syntax-case stx () - [(_ ([vars rhs] ...) . body) - (let* ([varses (syntax->list (syntax (vars ...)))] - [rhses (syntax->list (syntax (rhs ...)))] - [z:varses (map (lambda (vars) - (map (lambda (var) - (make-binding - stx - (mk-back) - (gensym (syntax-e var)) - (syntax-e var))) - (syntax->list vars))) - varses)] - [body-env (append - (apply - append - (map (lambda (z:vars vars) - (map (lambda (z:var var) - (cons - var - z:var)) - z:vars - (syntax->list vars))) - z:varses - varses)) - env)]) - (mk-let - stx - (mk-back) - z:varses - (map (lambda (rhs) - (loop rhs (if rec? body-env env))) - rhses) - (loop (syntax (begin . body)) body-env)))])) - - (define (args-s->z env args) - (let-values ([(maker ids) - (syntax-case args () - [id - (identifier? (syntax id)) - (values make-sym-arglist - (list (syntax id)))] - [(id ...) - (values make-list-arglist (syntax->list args))] - [_else (values make-ilist-arglist - (let loop ([args args]) - (syntax-case args () - [id (identifier? args) (list args)] - [(id . rest) - (cons (syntax id) (loop (syntax rest)))])))])]) - (let ([bindings - (map (lambda (id) - (make-binding - id - (mk-back) - (gensym (syntax-e id)) - (syntax-e id))) - ids)]) - (values - (append (map cons ids bindings) env) - (maker bindings))))) +(define (let-s->z mk-let rec? stx env loop) + (syntax-case stx () + [(_ ([vars rhs] ...) . body) + (let* ([varses (syntax->list (syntax (vars ...)))] + [rhses (syntax->list (syntax (rhs ...)))] + [z:varses (map (lambda (vars) + (map (lambda (var) + (make-binding + stx + (mk-back) + (gensym (syntax-e var)) + (syntax-e var))) + (syntax->list vars))) + varses)] + [body-env (append + (apply + append + (map (lambda (z:vars vars) + (map (lambda (z:var var) + (cons + var + z:var)) + z:vars + (syntax->list vars))) + z:varses + varses)) + env)]) + (mk-let + stx + (mk-back) + z:varses + (map (lambda (rhs) + (loop rhs (if rec? body-env env))) + rhses) + (loop (syntax (begin . body)) body-env)))])) - (define (syntax->zodiac stx) - (define slot-table (make-hash-table)) - (define trans-slot-table (make-hash-table)) - (define syntax-slot-table (make-hash-table)) +(define (args-s->z env args) + (let-values ([(maker ids) + (syntax-case args () + [id + (identifier? (syntax id)) + (values make-sym-arglist + (list (syntax id)))] + [(id ...) + (values make-list-arglist (syntax->list args))] + [_else (values make-ilist-arglist + (let loop ([args args]) + (syntax-case args () + [id (identifier? args) (list args)] + [(id . rest) + (cons (syntax id) (loop (syntax rest)))])))])]) + (let ([bindings + (map (lambda (id) + (make-binding + id + (mk-back) + (gensym (syntax-e id)) + (syntax-e id))) + ids)]) + (values + (append (map cons ids bindings) env) + (maker bindings))))) - (if (eof-object? stx) - stx - (let loop ([stx stx][env null][trans? #f]) - (kernel-syntax-case stx trans? - [id - (identifier? stx) - (let ([a (stx-bound-assq stx env)]) - (if a - ;; Lexical reference: - (make-bound-varref - stx - (mk-back) - (binding-var (cdr a)) - (cdr a)) - ;; Top-level (or module) reference: - (let ([b (let ([b ((if trans? - identifier-transformer-binding - identifier-binding) - stx)]) - ;; If b, is it imported? - (and (pair? b) - (let ([modname (and (pair? b) (car b))]) - (and (or (symbol? modname) - (and (module-path-index? modname) - (let-values ([(name base) (module-path-index-split modname)]) - (or name base)))) - b))))]) - (make-top-level-varref - stx - (mk-back) - (if b - (cadr b) - (syntax-e stx)) - (let ([modname (and b (car b))]) - modname) - (get-slot stx (if trans? trans-slot-table slot-table)) - trans? - (and b (list-ref b 4)) - (and b - ((if trans? - identifier-transformer-binding-export-position - identifier-binding-export-position) - stx))))))] +(define (syntax->zodiac stx) + (define slot-table (make-hash-table)) + (define trans-slot-table (make-hash-table)) + (define syntax-slot-table (make-hash-table)) - [(#%top . id) - ;; Top-level reference: - (make-top-level-varref - stx - (mk-back) - (syntax-e (syntax id)) - #f - (get-slot (syntax id) (if trans? trans-slot-table slot-table)) - trans? - #f - #f)] + (if (eof-object? stx) + stx + (let loop ([stx stx][env null][trans? #f]) + (kernel-syntax-case stx trans? + [id + (identifier? stx) + (let ([a (stx-bound-assq stx env)]) + (if a + ;; Lexical reference: + (make-bound-varref + stx + (mk-back) + (binding-var (cdr a)) + (cdr a)) + ;; Top-level (or module) reference: + (let ([b (let ([b ((if trans? + identifier-transformer-binding + identifier-binding) + stx)]) + ;; If b, is it imported? + (and (pair? b) + (let ([modname (and (pair? b) (car b))]) + (and (or (symbol? modname) + (and (module-path-index? modname) + (let-values ([(name base) (module-path-index-split modname)]) + (or name base)))) + b))))]) + (make-top-level-varref + stx + (mk-back) + (if b + (cadr b) + (syntax-e stx)) + (let ([modname (and b (car b))]) + modname) + (get-slot stx (if trans? trans-slot-table slot-table)) + trans? + (and b (list-ref b 4)) + (and b + ((if trans? + identifier-transformer-binding-export-position + identifier-binding-export-position) + stx))))))] - [(define-values names rhs) - (make-define-values-form - stx - (mk-back) - (map (lambda (stx) - (let ([b (identifier-binding stx)]) - (make-top-level-varref - stx - (mk-back) - (if (pair? b) - (cadr b) - (syntax-e stx)) - (and (pair? b) (car b)) - (get-slot stx slot-table) - #f - #f - #f))) - (syntax->list (syntax names))) - (loop (syntax rhs) null #f))] - - [(-define names rhs) - (or (module-identifier=? #'-define #'define-syntaxes) - (module-identifier=? #'-define #'define-values-for-syntax)) - (let ([for-stx? (module-identifier=? #'-define #'define-values-for-syntax)]) - ((if for-stx? - make-define-for-syntax-form - make-define-syntaxes-form) - stx - (mk-back) - (map (lambda (stx) - (let ([b (identifier-binding stx)]) - (make-top-level-varref - stx - (mk-back) - (if (pair? b) - (cadr b) - (syntax-e stx)) - (and (pair? b) (car b)) - (get-slot stx syntax-slot-table) - #f - for-stx? - #f))) - (syntax->list (syntax names))) - (loop (syntax rhs) null #t)))] - - [(module name init-require (#%plain-module-begin . body)) - (let* ([body (map (lambda (x) - (loop x env trans?)) - (syntax->list (syntax body)))] - [get-required-modules - (lambda (req) - (let loop ([body body]) - (cond - [(null? body) null] - [(and (require/provide-form? (car body)) - (module-identifier=? req (stx-car (zodiac-stx (car body))))) - (append - (map (lambda (r) - (syntax-case* r (prefix all-except rename) - (lambda (a b) (eq? (syntax-e a) - (syntax-e b))) - [mod - (identifier? r) - r] - [(prefix id mod) - (syntax mod)] - [(rename mod . _) - (syntax mod)] - [(all-except mod . _) - (syntax mod)] - [_else r])) - (stx->list (stx-cdr (zodiac-stx (car body))))) - (loop (cdr body)))] - [else (loop (cdr body))])))] - [rt-required - (cons (syntax init-require) - (get-required-modules (quote-syntax require)))] - [et-required - (cons (syntax init-require) - (get-required-modules (quote-syntax require-for-syntax)))] - [tt-required - (cons (syntax init-require) - (get-required-modules (quote-syntax require-for-template)))] - [et-body - (filter (lambda (e) - (or (define-syntaxes-form? e) - (define-for-syntax-form? e))) - body)] - [rt-body - (filter (lambda (e) (and (not (define-syntaxes-form? e)) - (not (define-for-syntax-form? e)) - (not (require/provide-form? e)))) - body)]) - (make-module-form - stx - (mk-back) - (syntax name) - rt-required - et-required - tt-required - (make-begin-form - stx - (mk-back) - rt-body) - (make-begin-form - stx - (mk-back) - et-body) - (syntax-property stx 'module-variable-provides) - (syntax-property stx 'module-syntax-provides) - (syntax-property stx 'module-indirect-provides) - (syntax-property stx 'module-kernel-reprovide-hint) - (syntax-property stx 'module-self-path-index)))] - [(#%require i ...) - (make-require/provide-form - stx - (mk-back))] - [(#%provide i ...) - (make-require/provide-form - stx - (mk-back))] + [(#%top . id) + ;; Top-level reference: + (make-top-level-varref + stx + (mk-back) + (syntax-e (syntax id)) + #f + (get-slot (syntax id) (if trans? trans-slot-table slot-table)) + trans? + #f + #f)] - [(quote expr) - (make-quote-form - stx - (mk-back) - (make-zread (syntax expr)))] + [(define-values names rhs) + (make-define-values-form + stx + (mk-back) + (map (lambda (stx) + (let ([b (identifier-binding stx)]) + (make-top-level-varref + stx + (mk-back) + (if (pair? b) + (cadr b) + (syntax-e stx)) + (and (pair? b) (car b)) + (get-slot stx slot-table) + #f + #f + #f))) + (syntax->list (syntax names))) + (loop (syntax rhs) null #f))] + + [(-define names rhs) + (or (free-identifier=? #'-define #'define-syntaxes) + (free-identifier=? #'-define #'define-values-for-syntax)) + (let ([for-stx? (free-identifier=? #'-define #'define-values-for-syntax)]) + ((if for-stx? + make-define-for-syntax-form + make-define-syntaxes-form) + stx + (mk-back) + (map (lambda (stx) + (let ([b (identifier-binding stx)]) + (make-top-level-varref + stx + (mk-back) + (if (pair? b) + (cadr b) + (syntax-e stx)) + (and (pair? b) (car b)) + (get-slot stx syntax-slot-table) + #f + for-stx? + #f))) + (syntax->list (syntax names))) + (loop (syntax rhs) null #t)))] + + [(module name init-require (#%plain-module-begin . body)) + (let* ([body (map (lambda (x) + (loop x env trans?)) + (syntax->list (syntax body)))] + [get-required-modules + (lambda (req) + (let loop ([body body]) + (cond + [(null? body) null] + [(and (require/provide-form? (car body)) + (free-identifier=? req (stx-car (zodiac-stx (car body))))) + (append + (map (lambda (r) + (syntax-case* r (prefix all-except rename) + (lambda (a b) (eq? (syntax-e a) + (syntax-e b))) + [mod + (identifier? r) + r] + [(prefix id mod) + (syntax mod)] + [(rename mod . _) + (syntax mod)] + [(all-except mod . _) + (syntax mod)] + [_else r])) + (stx->list (stx-cdr (zodiac-stx (car body))))) + (loop (cdr body)))] + [else (loop (cdr body))])))] + [rt-required + (cons (syntax init-require) + (get-required-modules (quote-syntax require)))] + [et-required + (cons (syntax init-require) + (get-required-modules (quote-syntax require-for-syntax)))] + [tt-required + (cons (syntax init-require) + (get-required-modules (quote-syntax require-for-template)))] + [et-body + (filter (lambda (e) + (or (define-syntaxes-form? e) + (define-for-syntax-form? e))) + body)] + [rt-body + (filter (lambda (e) (and (not (define-syntaxes-form? e)) + (not (define-for-syntax-form? e)) + (not (require/provide-form? e)))) + body)]) + (make-module-form + stx + (mk-back) + (syntax name) + rt-required + et-required + tt-required + (make-begin-form + stx + (mk-back) + rt-body) + (make-begin-form + stx + (mk-back) + et-body) + (syntax-property stx 'module-variable-provides) + (syntax-property stx 'module-syntax-provides) + (syntax-property stx 'module-indirect-provides) + (syntax-property stx 'module-kernel-reprovide-hint) + (syntax-property stx 'module-self-path-index)))] + [(#%require i ...) + (make-require/provide-form + stx + (mk-back))] + [(#%provide i ...) + (make-require/provide-form + stx + (mk-back))] - [(quote-syntax expr) - (make-quote-syntax-form - stx - (mk-back) - (syntax expr))] - - [(#%plain-lambda args . body) - (let-values ([(env args) (args-s->z env (syntax args))]) - (make-case-lambda-form - stx - (mk-back) - (list args) - (list (loop (syntax (begin . body)) env trans?))))] - [(case-lambda [args . body] ...) - (let-values ([(envs argses) - (let ([es+as - (map - (lambda (args) - (let-values ([(env args) (args-s->z env args)]) - (cons env args))) - (syntax->list (syntax (args ...))))]) - (values - (map car es+as) - (map cdr es+as)))]) - (make-case-lambda-form - stx - (mk-back) - argses - (map (lambda (env body) - (with-syntax ([body body]) - (loop (syntax (begin . body)) env trans?))) - envs - (syntax->list (syntax (body ...))))))] + [(quote expr) + (make-quote-form + stx + (mk-back) + (make-zread (syntax expr)))] - [(let-values . _) - (let-s->z make-let-values-form #f stx env - (lambda (b env) (loop b env trans?)))] - [(letrec-values . _) - (let-s->z make-letrec-values-form #t stx env - (lambda (b env) (loop b env trans?)))] - - [(set! var rhs) - (make-set!-form - stx - (mk-back) - (loop (syntax var) env trans?) - (loop (syntax rhs) env trans?))] - - [(begin . exprs) - (make-begin-form - stx - (mk-back) - (map (lambda (x) - (loop x env trans?)) - (syntax->list (syntax exprs))))] - - [(begin0 . exprs) - (make-begin0-form - stx - (mk-back) - (map (lambda (x) - (loop x env trans?)) - (syntax->list (syntax exprs))))] + [(quote-syntax expr) + (make-quote-syntax-form + stx + (mk-back) + (syntax expr))] + + [(#%plain-lambda args . body) + (let-values ([(env args) (args-s->z env (syntax args))]) + (make-case-lambda-form + stx + (mk-back) + (list args) + (list (loop (syntax (begin . body)) env trans?))))] + [(case-lambda [args . body] ...) + (let-values ([(envs argses) + (let ([es+as + (map + (lambda (args) + (let-values ([(env args) (args-s->z env args)]) + (cons env args))) + (syntax->list (syntax (args ...))))]) + (values + (map car es+as) + (map cdr es+as)))]) + (make-case-lambda-form + stx + (mk-back) + argses + (map (lambda (env body) + (with-syntax ([body body]) + (loop (syntax (begin . body)) env trans?))) + envs + (syntax->list (syntax (body ...))))))] - [(if test then) - (make-if-form - stx - (mk-back) - (loop (syntax test) env trans?) - (loop (syntax then) env trans?) - (loop (syntax (#%plain-app void)) env trans?))] + [(let-values . _) + (let-s->z make-let-values-form #f stx env + (lambda (b env) (loop b env trans?)))] + [(letrec-values . _) + (let-s->z make-letrec-values-form #t stx env + (lambda (b env) (loop b env trans?)))] + + [(set! var rhs) + (make-set!-form + stx + (mk-back) + (loop (syntax var) env trans?) + (loop (syntax rhs) env trans?))] + + [(begin . exprs) + (make-begin-form + stx + (mk-back) + (map (lambda (x) + (loop x env trans?)) + (syntax->list (syntax exprs))))] + + [(begin0 . exprs) + (make-begin0-form + stx + (mk-back) + (map (lambda (x) + (loop x env trans?)) + (syntax->list (syntax exprs))))] - [(if test then else) - (make-if-form - stx - (mk-back) - (loop (syntax test) env trans?) - (loop (syntax then) env trans?) - (loop (syntax else) env trans?))] + [(if test then else) + (make-if-form + stx + (mk-back) + (loop (syntax test) env trans?) + (loop (syntax then) env trans?) + (loop (syntax else) env trans?))] - [(with-continuation-mark k v body) - (make-with-continuation-mark-form - stx - (mk-back) - (loop (syntax k) env trans?) - (loop (syntax v) env trans?) - (loop (syntax body) env trans?))] + [(with-continuation-mark k v body) + (make-with-continuation-mark-form + stx + (mk-back) + (loop (syntax k) env trans?) + (loop (syntax v) env trans?) + (loop (syntax body) env trans?))] - [(#%plain-app 'gp vec (quote pos)) - (and (eq? (syntax-e #'gp) global-prepare-id) - (number? (syntax-e #'pos))) - (make-global-prepare - stx - (mk-back) - (loop (syntax vec) env trans?) - (syntax-e #'pos))] - [(#%plain-app 'gl vec (quote pos)) - (and (eq? (syntax-e #'gl) global-lookup-id) - (number? (syntax-e #'pos))) - (make-global-lookup - stx - (mk-back) - (loop (syntax vec) env trans?) - (syntax-e #'pos))] - [(#%plain-app 'ga vec (quote pos) val) - (and (eq? (syntax-e #'ga) global-assign-id) - (number? (syntax-e #'pos))) - (make-global-assign - stx - (mk-back) - (loop (syntax vec) env trans?) - (syntax-e #'pos) - (loop (syntax val) env trans?))] - [(#%plain-app 'svr vec (quote pos)) - (and (eq? (syntax-e #'svr) safe-vector-ref-id) - (number? (syntax-e #'pos))) - (make-safe-vector-ref - stx - (mk-back) - (loop (syntax vec) env trans?) - (syntax-e #'pos))] - - [(#%plain-app) - (make-quote-form - (syntax/loc stx ()) - (mk-back) - (make-zread (quote-syntax ())))] - [(#%plain-app func arg ...) - (make-app - stx - (mk-back) - (loop (syntax func) env trans?) - (map - (lambda (arg) - (loop arg env trans?)) - (syntax->list (syntax (arg ...)))))] + [(#%plain-app 'gp vec (quote pos)) + (and (eq? (syntax-e #'gp) global-prepare-id) + (number? (syntax-e #'pos))) + (make-global-prepare + stx + (mk-back) + (loop (syntax vec) env trans?) + (syntax-e #'pos))] + [(#%plain-app 'gl vec (quote pos)) + (and (eq? (syntax-e #'gl) global-lookup-id) + (number? (syntax-e #'pos))) + (make-global-lookup + stx + (mk-back) + (loop (syntax vec) env trans?) + (syntax-e #'pos))] + [(#%plain-app 'ga vec (quote pos) val) + (and (eq? (syntax-e #'ga) global-assign-id) + (number? (syntax-e #'pos))) + (make-global-assign + stx + (mk-back) + (loop (syntax vec) env trans?) + (syntax-e #'pos) + (loop (syntax val) env trans?))] + [(#%plain-app 'svr vec (quote pos)) + (and (eq? (syntax-e #'svr) safe-vector-ref-id) + (number? (syntax-e #'pos))) + (make-safe-vector-ref + stx + (mk-back) + (loop (syntax vec) env trans?) + (syntax-e #'pos))] + + [(#%plain-app) + (make-quote-form + (syntax/loc stx ()) + (mk-back) + (make-zread (quote-syntax ())))] + [(#%plain-app func arg ...) + (make-app + stx + (mk-back) + (loop (syntax func) env trans?) + (map + (lambda (arg) + (loop arg env trans?)) + (syntax->list (syntax (arg ...)))))] - [(#%expression e) - (loop (syntax e) env trans?)] - - [_else - (error 'syntax->zodiac - "unrecognized expression form: ~e" - (syntax-object->datum stx))])))) - - - (define (zodiac->syntax x) - (let loop ([x x]) - (cond - [(zread? x) - (zodiac-stx x)] - - [(top-level-varref? x) - (zodiac-stx x)] - [(bound-varref? x) - ;; An stx object is getting gensymmed here! - (datum->syntax-object #f (binding-var (bound-varref-binding x)) #f)] - - [(app? x) - (with-syntax ([fun (loop (app-fun x))] - [args (map loop (app-args x))]) - (syntax (#%plain-app fun . args)))] - - [(if-form? x) - (with-syntax ([test (loop (if-form-test x))] - [then (loop (if-form-then x))] - [else (loop (if-form-else x))]) - (syntax (if test then else)))] - - [(quote-form? x) - (with-syntax ([v (zodiac-stx (quote-form-expr x))]) - (syntax (quote v)))] - [(quote-syntax-form? x) - (with-syntax ([v (quote-syntax-form-expr x)]) - (syntax (quote-syntax v)))] - - [(begin-form? x) - (with-syntax ([body (map loop (begin-form-bodies))]) - (syntax (begin . body)))] - [(begin0-form? x) - (with-syntax ([body (map loop (begin-form-bodies))]) - (syntax (begin0 . body)))] - - [(let-values-form? x) - (with-syntax ([(vars ...) - (map (lambda (vars) - (map binding-var vars)) - (let-values-form-vars x))] - [(val ...) - (map loop (let-values-form-vals x))] - [body (loop (let-values-form-body x))]) - (syntax (let-values ([vars val] ...) body)))] - [(letrec-values-form? x) - (with-syntax ([(vars ...) - (map (lambda (vars) - (map binding-var vars)) - (letrec-values-form-vars x))] - [(val ...) - (map loop (letrec-values-form-vals x))] - [body (loop (letrec-values-form-body x))]) - (syntax (letrec-values ([vars val] ...) body)))] - - [(define-values-form? x) - (with-syntax ([vars (map zodiac-stx (define-values-form-vars x))] - [val (loop (define-values-form-val x))]) - (syntax (define-values vars val)))] - - [(set!-form? x) - (with-syntax ([var (loop (set!-form-var x))] - [val (loop (set!-form-val x))]) - (syntax (set! var val)))] - - [(case-lambda-form? x) - (with-syntax ([(args ...) - (map (lambda (args) - (cond - [(sym-arglist? args) - (datum->syntax-object #f (binding-var (car (arglist-vars args))) #f)] - [(list-arglist? args) - (map (lambda (var) - (datum->syntax-object #f (binding-var var) #f)) - (arglist-vars args))] - [(ilist-arglist? args) - (let loop ([vars (arglist-vars args)]) - (let ([id (datum->syntax-object #f (binding-var (car vars)) #f)]) - (if (null? (cdr vars)) - id - (cons id (loop (cdr vars))))))])) - (case-lambda-form-args x))] - [(body ...) - (map loop (case-lambda-form-bodies x))]) - (syntax (case-lambda [args body] ...)))] - - [(with-continuation-mark-form? x) - (with-syntax ([key (loop (with-continuation-mark-form-key x))] - [val (loop (with-continuation-mark-form-val x))] - [body (loop (with-continuation-mark-form-body x))]) - (syntax (with-continuation-mark key val body)))] - - [else (error 'zodiac->syntax - "unknown zodiac record type: ~e" - x)]))) - - (define (zodiac-origin z) z) - - (define (origin-who z) - (if (syntax-original? (zodiac-stx z)) - 'source - 'macro)) - - (define (origin-how z) - (syntax-property (zodiac-stx z) 'origin)) - - (define (zodiac-start z) z) - (define (zodiac-finish z) z) - - (define (location-line z) - (and (zodiac-stx z) (syntax-line (zodiac-stx z)))) - - (define (location-column z) - (and (zodiac-stx z) (syntax-column (zodiac-stx z)))) - - (define (location-file z) - (and (zodiac-stx z) (syntax-source (zodiac-stx z)))) - - (define (zread-object z) - (syntax-e (zodiac-stx z))) - - (define (structurize-syntax sexp) - (make-zread (datum->syntax-object #f sexp #f))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define eof? eof-object?) - - (define-struct zodiac (stx)) - (define-struct (zread zodiac) ()) - - (define-struct (parsed zodiac) (back)) - - (define-struct (varref parsed) (var)) - - (define-struct (top-level-varref varref) (module slot exptime? expdef? position)) - (define (create-top-level-varref z var module slot exptime? expdef? position) - (make-top-level-varref (zodiac-stx z) (mk-back) var module slot exptime? expdef? position)) - - (define-struct (bound-varref varref) (binding)) - (define (create-bound-varref z var binding) - (make-bound-varref (zodiac-stx z) (mk-back) var binding)) - - (define lexical-varref? bound-varref?) - (define make-lexical-varref make-bound-varref) - (define create-lexical-varref create-bound-varref) - - (define-struct (binding parsed) (var orig-name)) - (define (create-binding z var orig-name) - (make-binding (zodiac-stx z) (mk-back) var orig-name)) - - (define lexical-binding? binding?) - (define make-lexical-binding make-binding) - (define create-lexical-binding create-binding) + [(#%expression e) + (loop (syntax e) env trans?)] + + [_else + (error 'syntax->zodiac + "unrecognized expression form: ~e" + (syntax->datum stx))])))) - (define-struct (app parsed) (fun args)) - (define (create-app z fun args) - (make-app (zodiac-stx z) (mk-back) fun args)) +(define (zodiac->syntax x) + (let loop ([x x]) + (cond + [(zread? x) + (zodiac-stx x)] - (define-struct (if-form parsed) (test then else)) - (define (create-if-form z test then else) - (make-if-form (zodiac-stx z) (mk-back) test then else)) + [(top-level-varref? x) + (zodiac-stx x)] + [(bound-varref? x) + ;; An stx object is getting gensymmed here! + (datum->syntax #f (binding-var (bound-varref-binding x)) #f)] + + [(app? x) + (with-syntax ([fun (loop (app-fun x))] + [args (map loop (app-args x))]) + (syntax (#%plain-app fun . args)))] - (define-struct (quote-form parsed) (expr)) - (define (create-quote-form z expr) - (make-quote-form (zodiac-stx z) (mk-back) expr)) + [(if-form? x) + (with-syntax ([test (loop (if-form-test x))] + [then (loop (if-form-then x))] + [else (loop (if-form-else x))]) + (syntax (if test then else)))] - (define-struct (begin-form parsed) (bodies)) - (define (create-begin-form z bodies) - (make-begin-form (zodiac-stx z) (mk-back) bodies)) + [(quote-form? x) + (with-syntax ([v (zodiac-stx (quote-form-expr x))]) + (syntax (quote v)))] + [(quote-syntax-form? x) + (with-syntax ([v (quote-syntax-form-expr x)]) + (syntax (quote-syntax v)))] - (define-struct (begin0-form parsed) (bodies)) - (define (create-begin0-form z bodies) - (make-begin0-form (zodiac-stx z) (mk-back) bodies)) + [(begin-form? x) + (with-syntax ([body (map loop (begin-form-bodies))]) + (syntax (begin . body)))] + [(begin0-form? x) + (with-syntax ([body (map loop (begin-form-bodies))]) + (syntax (begin0 . body)))] - (define-struct (let-values-form parsed) (vars vals body)) - (define (create-let-values-form z vars vals body) - (make-let-values-form (zodiac-stx z) (mk-back) vars vals body)) + [(let-values-form? x) + (with-syntax ([(vars ...) + (map (lambda (vars) + (map binding-var vars)) + (let-values-form-vars x))] + [(val ...) + (map loop (let-values-form-vals x))] + [body (loop (let-values-form-body x))]) + (syntax (let-values ([vars val] ...) body)))] + [(letrec-values-form? x) + (with-syntax ([(vars ...) + (map (lambda (vars) + (map binding-var vars)) + (letrec-values-form-vars x))] + [(val ...) + (map loop (letrec-values-form-vals x))] + [body (loop (letrec-values-form-body x))]) + (syntax (letrec-values ([vars val] ...) body)))] + + [(define-values-form? x) + (with-syntax ([vars (map zodiac-stx (define-values-form-vars x))] + [val (loop (define-values-form-val x))]) + (syntax (define-values vars val)))] + + [(set!-form? x) + (with-syntax ([var (loop (set!-form-var x))] + [val (loop (set!-form-val x))]) + (syntax (set! var val)))] + + [(case-lambda-form? x) + (with-syntax ([(args ...) + (map (lambda (args) + (cond + [(sym-arglist? args) + (datum->syntax #f (binding-var (car (arglist-vars args))) #f)] + [(list-arglist? args) + (map (lambda (var) + (datum->syntax #f (binding-var var) #f)) + (arglist-vars args))] + [(ilist-arglist? args) + (let loop ([vars (arglist-vars args)]) + (let ([id (datum->syntax #f (binding-var (car vars)) #f)]) + (if (null? (cdr vars)) + id + (cons id (loop (cdr vars))))))])) + (case-lambda-form-args x))] + [(body ...) + (map loop (case-lambda-form-bodies x))]) + (syntax (case-lambda [args body] ...)))] - (define-struct (letrec-values-form parsed) (vars vals body)) - (define (create-letrec-values-form z vars vals body) - (make-letrec-values-form (zodiac-stx z) (mk-back) vars vals body)) + [(with-continuation-mark-form? x) + (with-syntax ([key (loop (with-continuation-mark-form-key x))] + [val (loop (with-continuation-mark-form-val x))] + [body (loop (with-continuation-mark-form-body x))]) + (syntax (with-continuation-mark key val body)))] - (define-struct (define-values-form parsed) (vars val)) - (define (create-define-values-form z vars val) - (make-define-values-form (zodiac-stx z) (mk-back) vars val)) + [else (error 'zodiac->syntax + "unknown zodiac record type: ~e" + x)]))) - (define-struct (set!-form parsed) (var val)) - (define (create-set!-form z var val) - (make-set!-form (zodiac-stx z) (mk-back) var val)) +(define (zodiac-origin z) z) - (define-struct (case-lambda-form parsed) (args bodies)) - (define (create-case-lambda-form z args bodies) - (make-case-lambda-form (zodiac-stx z) (mk-back) args bodies)) +(define (origin-who z) + (if (syntax-original? (zodiac-stx z)) + 'source + 'macro)) - (define-struct (with-continuation-mark-form parsed) (key val body)) - (define (create-with-continuation-mark-form z key val body) - (make-with-continuation-mark-form (zodiac-stx z) (mk-back) key val body)) +(define (origin-how z) + (syntax-property (zodiac-stx z) 'origin)) - (define-struct (quote-syntax-form parsed) (expr)) - (define (create-quote-syntax-form z expr) - (make-quote-syntax-form (zodiac-stx z) (mk-back) expr)) +(define (zodiac-start z) z) +(define (zodiac-finish z) z) - (define-struct (define-syntaxes-form parsed) (names expr)) - (define (create-define-syntaxes-form z names expr) - (make-define-syntaxes-form (zodiac-stx z) (mk-back) names expr)) +(define (location-line z) + (and (zodiac-stx z) (syntax-line (zodiac-stx z)))) - (define-struct (define-for-syntax-form parsed) (names expr)) - (define (create-define-for-syntax-form z names expr) - (make-define-for-syntax-form (zodiac-stx z) (mk-back) names expr)) +(define (location-column z) + (and (zodiac-stx z) (syntax-column (zodiac-stx z)))) - (define-struct (module-form parsed) (name requires for-syntax-requires for-template-requires - body syntax-body - provides syntax-provides indirect-provides - kernel-reprovide-hint - self-path-index)) - (define (create-module-form z name rt-requires et-requires tt-requires - rt-body et-body - var-provides syntax-provides indirect-provides - kernel-hint self) - (make-module-form (zodiac-stx z) (mk-back) - name rt-requires et-requires tt-requires - rt-body et-body - var-provides syntax-provides indirect-provides - kernel-hint self)) +(define (location-file z) + (and (zodiac-stx z) (syntax-source (zodiac-stx z)))) - (define-struct (require/provide-form parsed) ()) - (define (create-require/provide-form z) - (make-require/provide-form (zodiac-stx z) (mk-back))) - - (define-struct (global-prepare parsed) (vec pos)) - (define (create-global-prepare z vec pos) - (make-global-prepare (zodiac-stx z) (mk-back) vec pos)) +(define (zread-object z) + (syntax-e (zodiac-stx z))) - (define-struct (global-lookup parsed) (vec pos)) - (define (create-global-lookup z vec pos) - (make-global-lookup (zodiac-stx z) (mk-back) vec pos)) +(define (structurize-syntax sexp) + (make-zread (datum->syntax #f sexp #f))) - (define-struct (global-assign parsed) (vec pos expr)) - (define (create-global-assign z vec pos expr) - (make-global-assign (zodiac-stx z) (mk-back) vec pos expr)) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define-struct (safe-vector-ref parsed) (vec pos)) - (define (create-safe-vector-ref z vec pos) - (make-safe-vector-ref (zodiac-stx z) (mk-back) vec pos)) +(define eof? eof-object?) - (define-struct arglist (vars)) - (define-struct (sym-arglist arglist) ()) - (define-struct (list-arglist arglist) ()) - (define-struct (ilist-arglist arglist) ()) +(define-struct zodiac (stx) #:mutable) +(define-struct (zread zodiac) () #:mutable) + +(define-struct (parsed zodiac) (back) #:mutable) + +(define-struct (varref parsed) (var) #:mutable) + +(define-struct (top-level-varref varref) (module slot exptime? expdef? position) #:mutable) +(define (create-top-level-varref z var module slot exptime? expdef? position) + (make-top-level-varref (zodiac-stx z) (mk-back) var module slot exptime? expdef? position)) + +(define-struct (bound-varref varref) (binding) #:mutable) +(define (create-bound-varref z var binding) + (make-bound-varref (zodiac-stx z) (mk-back) var binding)) + +(define lexical-varref? bound-varref?) +(define make-lexical-varref make-bound-varref) +(define create-lexical-varref create-bound-varref) + +(define-struct (binding parsed) (var orig-name) #:mutable) +(define (create-binding z var orig-name) + (make-binding (zodiac-stx z) (mk-back) var orig-name)) + +(define lexical-binding? binding?) +(define make-lexical-binding make-binding) +(define create-lexical-binding create-binding) + + +(define-struct (app parsed) (fun args) #:mutable) +(define (create-app z fun args) + (make-app (zodiac-stx z) (mk-back) fun args)) + +(define-struct (if-form parsed) (test then else) #:mutable) +(define (create-if-form z test then else) + (make-if-form (zodiac-stx z) (mk-back) test then else)) + +(define-struct (quote-form parsed) (expr) #:mutable) +(define (create-quote-form z expr) + (make-quote-form (zodiac-stx z) (mk-back) expr)) + +(define-struct (begin-form parsed) (bodies) #:mutable) +(define (create-begin-form z bodies) + (make-begin-form (zodiac-stx z) (mk-back) bodies)) + +(define-struct (begin0-form parsed) (bodies) #:mutable) +(define (create-begin0-form z bodies) + (make-begin0-form (zodiac-stx z) (mk-back) bodies)) + +(define-struct (let-values-form parsed) (vars vals body) #:mutable) +(define (create-let-values-form z vars vals body) + (make-let-values-form (zodiac-stx z) (mk-back) vars vals body)) + +(define-struct (letrec-values-form parsed) (vars vals body) #:mutable) +(define (create-letrec-values-form z vars vals body) + (make-letrec-values-form (zodiac-stx z) (mk-back) vars vals body)) + +(define-struct (define-values-form parsed) (vars val) #:mutable) +(define (create-define-values-form z vars val) + (make-define-values-form (zodiac-stx z) (mk-back) vars val)) + +(define-struct (set!-form parsed) (var val) #:mutable) +(define (create-set!-form z var val) + (make-set!-form (zodiac-stx z) (mk-back) var val)) + +(define-struct (case-lambda-form parsed) (args bodies) #:mutable) +(define (create-case-lambda-form z args bodies) + (make-case-lambda-form (zodiac-stx z) (mk-back) args bodies)) + +(define-struct (with-continuation-mark-form parsed) (key val body) #:mutable) +(define (create-with-continuation-mark-form z key val body) + (make-with-continuation-mark-form (zodiac-stx z) (mk-back) key val body)) + +(define-struct (quote-syntax-form parsed) (expr) #:mutable) +(define (create-quote-syntax-form z expr) + (make-quote-syntax-form (zodiac-stx z) (mk-back) expr)) + +(define-struct (define-syntaxes-form parsed) (names expr) #:mutable) +(define (create-define-syntaxes-form z names expr) + (make-define-syntaxes-form (zodiac-stx z) (mk-back) names expr)) + +(define-struct (define-for-syntax-form parsed) (names expr) #:mutable) +(define (create-define-for-syntax-form z names expr) + (make-define-for-syntax-form (zodiac-stx z) (mk-back) names expr)) + +(define-struct (module-form parsed) (name requires for-syntax-requires for-template-requires + body syntax-body + provides syntax-provides indirect-provides + kernel-reprovide-hint + self-path-index) + #:mutable) +(define (create-module-form z name rt-requires et-requires tt-requires + rt-body et-body + var-provides syntax-provides indirect-provides + kernel-hint self) + (make-module-form (zodiac-stx z) (mk-back) + name rt-requires et-requires tt-requires + rt-body et-body + var-provides syntax-provides indirect-provides + kernel-hint self)) + +(define-struct (require/provide-form parsed) ()) +(define (create-require/provide-form z) + (make-require/provide-form (zodiac-stx z) (mk-back))) + +(define-struct (global-prepare parsed) (vec pos) #:mutable) +(define (create-global-prepare z vec pos) + (make-global-prepare (zodiac-stx z) (mk-back) vec pos)) + +(define-struct (global-lookup parsed) (vec pos) #:mutable) +(define (create-global-lookup z vec pos) + (make-global-lookup (zodiac-stx z) (mk-back) vec pos)) + +(define-struct (global-assign parsed) (vec pos expr) #:mutable) +(define (create-global-assign z vec pos expr) + (make-global-assign (zodiac-stx z) (mk-back) vec pos expr)) + +(define-struct (safe-vector-ref parsed) (vec pos) #:mutable) +(define (create-safe-vector-ref z vec pos) + (make-safe-vector-ref (zodiac-stx z) (mk-back) vec pos)) + +(define-struct arglist (vars) #:mutable) +(define-struct (sym-arglist arglist) () #:mutable) +(define-struct (list-arglist arglist) () #:mutable) +(define-struct (ilist-arglist arglist) () #:mutable) diff --git a/collects/texpict/private/common-sig.ss b/collects/texpict/private/common-sig.ss index d10bb81838..71918223ad 100644 --- a/collects/texpict/private/common-sig.ss +++ b/collects/texpict/private/common-sig.ss @@ -1,5 +1,5 @@ -(module common-sig mzscheme - (require (lib "unit.ss")) +(module common-sig scheme/base + (require scheme/unit) (provide texpict-common^) (define-signature texpict-common^ diff --git a/collects/texpict/private/common-unit.ss b/collects/texpict/private/common-unit.ss index 3b93e59db0..6ddde9f8b3 100644 --- a/collects/texpict/private/common-unit.ss +++ b/collects/texpict/private/common-unit.ss @@ -17,7 +17,8 @@ ascent ; portion of height above top baseline descent ; portion of height below bottom baseline children ; list of child records - panbox)) ; panorama box + panbox) ; panorama box + #:mutable) (define-struct child (pict dx dy sx sy)) (define-struct bbox (x1 y1 x2 y2 ay dy))