diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 559f439b..774f694c 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -155,11 +155,13 @@ (symbol value test) "This function must be called every time your application starts up, before any call to" "@flink preferences:get %" + ", " + "@flink preferences:set %" "." "" "If you use" "@flink preferences:set-un/marshall %" - ", you must also call it before calling this function." + ", you must call this function before calling it." "" "This sets the default value of the preference \\var{symbol} to" "\\var{value}. If the user has chosen a different setting," @@ -173,11 +175,7 @@ "used." "" "If there is a site-wide default preferences file, the default" - "preference in that file is used instead of \\var{value}." - "" - "Once" - "@flink preferences:start-writing-timer " - "has been called, no more default preferences may be registered.") + "preference in that file is used instead of \\var{value}.") (preferences:set-un/marshall (symbol? (any? . -> . printable?) (printable? . -> . any?) . -> . void?) (symbol marshall unmarshall) @@ -203,9 +201,9 @@ "by hand." "" "\\rawscm{preference:set-un/marshall} must be called before calling" - "@flink preferences:get " - "or " - "@flink preferences:set-default %" + "@flink preferences:get %" + ", " + "@flink preferences:set %" ".") (preferences:save (-> boolean?) @@ -223,13 +221,6 @@ () "\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the" "default preferences.") - (preferences:start-writing-timer - (-> void?) - () - "Starts a thread that periodically flushes the preferences" - "to disk reads them from the disk (if the prefs have changed on the disk." - "" - "Once this function has been called, no new preferences may be registered.") (preferences:add-panel ((union string? (cons/p string? (listof string?))) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 5c7d6c10..111648a6 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -24,7 +24,10 @@ (define main-preferences-symbol 'plt:framework-prefs) - ;; preferences : sym -o> (union marshalled pref) + ;; preferences : sym -o> (union marshalled any) + ;; for a given preference symbol, p, + ;; when the table maps to a marshalled struct, the + ;; preference has not been examined (via get or set) (define preferences (make-hash-table)) ;; marshall-unmarshall : sym -o> un/marshall @@ -40,96 +43,81 @@ ;; the mapped symbols are the ones that have changed ;; but not yet written out to disk. (define changed (make-hash-table)) - - ;; no-more-defaults? : boolean - ;; when #t, no more default prefs may be set. - (define no-more-defaults? #f) - + + ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any)) (define-struct un/marshall (marshall unmarshall)) + + ;; type marshalled = (make-marshalled printable) (define-struct marshalled (data)) + + ;; type pref = (make-pref any) (define-struct pref (value)) + + ;; type default = (make-default any (any -> bool)) (define-struct default (value checker)) - ;; reset-changed : -> void - ;; resets the changed table to indicate no changes have occurred - (define (reset-changed) - (set! changed (make-hash-table))) - - ;; add-changed-pref : symbol -> void - ;; marks the pref p as changed - (define (add-changed-pref p) - (hash-table-put! changed p #t)) - - ;; periodically checks to see if changes need to be written out. - (define (start-writing-timer) - (set! no-more-defaults? #t) - ;; don't actually start the timer anymore. - ;; turns out that preferences are set far too often - ;; and I need a better test for when things should be written out. - '(new timer% - [notify-callback (lambda () (maybe-flush-changes))] - [interval (* 10 1000)]) - (void)) - - (define last-time-read #f) - (define (maybe-flush-changes) - - ;; writing out changes - (let ([changed-syms (hash-table-map changed (lambda (k v) k))]) - (unless (null? changed-syms) - (let/ec k - (let ([sexp (get-disk-prefs (lambda () (k #f)))]) - (install-stashed-preferences sexp changed-syms) - (raw-save #t) - (reset-changed))))) - - ;; reading in changes - (let* ([filename (find-system-path 'pref-file)]) - (when (file-exists? filename) - (let ([mod (file-or-directory-modify-seconds filename)]) - (when (or (not last-time-read) - (last-time-read . < . mod)) - (let* ([failed? #f] - [new-stuff (get-preference main-preferences-symbol (lambda () (set! failed? #t)))]) - (unless failed? - (set! last-time-read mod) - (install-stashed-preferences new-stuff '()) - (reset-changed)))))))) + ;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void))) + ;; this is used as a wrapped to deal with the problem that different procedures might be eq?. + (define-struct pref-callback (cb)) - (define guard - (lambda (when p value thunk) - (with-handlers ([exn:fail? - (lambda (exn) - (error "excetion raised ~s, pref ~s val ~s, msg: ~a" - when - p - value - (if (exn? exn) - (exn-message exn) - (format "~s" exn))))]) - (thunk)))) + ;; get : symbol -> any + ;; return the current value of the preference `p' + ;; exported + (define (get p) + (unless (hash-table-bound? defaults p) + (raise-unknown-preference-error + "preferences:get: tried to get a preference but no default set for ~e" + p)) + (let ([res + (hash-table-get preferences + p + (lambda () + (let ([def (hash-table-get defaults p)]) + (default-value def))))]) + (cond + [(marshalled? res) + (let ([unmarshalled (unmarshall p res)]) + (hash-table-put! preferences p unmarshalled) + unmarshalled)] + [else res]))) + + ;; set : symbol any -> void + ;; updates the preference + ;; exported + (define (set p value) + (let ([default (hash-table-get + defaults p + (lambda () + (raise-unknown-preference-error + "preferences:set: tried to set the preference ~e to ~e, but no default is set" + p + value)))]) + (unless ((default-checker default) value) + (error 'preferences:set + "tried to set preference ~e to ~e but it does not meet test from preferences:set-default" + p value)) + (check-callbacks p value) + (hash-table-put! preferences p value))) + + (define (raise-unknown-preference-error fmt . args) + (raise (exn:make-unknown-preference + (string->immutable-string (apply format fmt args)) + (current-continuation-marks)))) + ;; unmarshall : symbol marshalled -> any + ;; unmarshalls a preference read from the disk (define (unmarshall p marshalled) (let/ec k (let* ([data (marshalled-data marshalled)] [unmarshall-fn (un/marshall-unmarshall (hash-table-get marshall-unmarshall p - (lambda () (k data))))]) - (with-handlers ([exn:fail? - (lambda (exn) - (begin0 - (hash-table-get defaults p (lambda () (raise exn))) - (message-box (format (string-constant error-unmarshalling) p) - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn)))))]) - (unmarshall-fn data))))) - - ;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void))) - ;; this is used as a wrapped to hack around the problem - ;; that different procedures might be eq?. - (define-struct pref-callback (cb)) + (lambda () (k data))))] + [default (hash-table-get defaults p)]) + (let ([result (unmarshall-fn data)]) + (if ((default-checker default) result) + result + (default-value default)))))) ;; add-callback : sym (-> void) -> void (define add-callback @@ -171,78 +159,30 @@ (let ([v (weak-box-value cb)]) (if v (begin - (guard "calling callback" p value - (lambda () (v p value))) + (v p value) (cons callback (loop (cdr callbacks)))) (loop (cdr callbacks))))] [else - (guard "calling callback" p value - (lambda () (cb p value))) + (cb p value) (cons callback (loop (cdr callbacks)))]))]))]) (if (null? new-callbacks) (hash-table-remove! callbacks p) (hash-table-put! callbacks p new-callbacks)))) - (define (get p) - (let ([ans (hash-table-get preferences p - (lambda () - (raise (exn:make-unknown-preference - (format "preferences:get: attempted to get unknown preference: ~e" p) - (current-continuation-marks)))))]) - (cond - [(marshalled? ans) - (let* ([default-s - (hash-table-get - defaults p - (lambda () - (raise (exn:make-unknown-preference - (format "preferences:get: no default pref for: ~e" p) - (current-continuation-marks)))))] - [default (default-value default-s)] - [checker (default-checker default-s)] - [unmarshalled (let ([unmarsh (unmarshall p ans)]) - (if (checker unmarsh) - unmarsh - default))] - [pref (begin (check-callbacks p unmarshalled) - unmarshalled)]) - (hash-table-put! preferences p (make-pref pref)) - pref)] - [(pref? ans) - (pref-value ans)] - [else (error 'prefs.ss "robby error.1: ~a" ans)]))) - - (define (default-set? p) - (let/ec k - (hash-table-get defaults p (lambda () (k #f))) - #t)) - - ;; set : symbol any -> void - ;; updates the preference - (define (set p value) - (add-changed-pref p) - (let* ([pref (hash-table-get preferences p (lambda () #f))]) - (unless (default-set? p) - (error 'preferences:set "tried to set a preference but no default set for ~e, with ~e" - p value)) - (cond - [(pref? pref) - (check-callbacks p value) - (set-pref-value! pref value)] - [(or (marshalled? pref) - (not pref)) - (check-callbacks p value) - (hash-table-put! preferences p (make-pref value))] - [else - (error 'prefs.ss "robby error.0: ~a" pref)]))) - (define set-un/marshall (lambda (p marshall unmarshall) - (unless (default-set? p) + (unless (hash-table-bound? defaults p) (error 'set-un/marshall "must call set-default for ~s before calling set-un/marshall for ~s" p p)) + (when (pref-has-value? p) + (error 'preferences:set-un/marshall "a value for the preference ~e has already been looked up or set" p)) (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall)))) + (define (hash-table-bound? ht s) + (let/ec k + (hash-table-get ht s (lambda () (k #f))) + #t)) + (define restore-defaults (lambda () (hash-table-for-each @@ -251,24 +191,31 @@ ;; set-default : (sym TST (TST -> boolean) -> void (define (set-default p default-value checker) - (when no-more-defaults? - (error 'set-default "tried to register the pref ~e too late; preferences:start-writing-timer has already been called" p)) + (when (pref-has-value? p) + (error 'preferences:set-default + "tried to call set-default for preference ~e but it already has a value" + p)) (let ([default-okay? (checker default-value)]) (unless default-okay? (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker default-okay? default-value)) - (hash-table-get preferences p - (lambda () - (hash-table-put! preferences p (make-pref default-value)))) (hash-table-put! defaults p (make-default default-value checker)))) + ;; pref-has-value? : symbol -> boolean + ;; returns #t if the preference's value has been examined with set or get + (define (pref-has-value? p) + (let/ec k + (let ([b (hash-table-get preferences p (lambda () (k #f)))]) + (not (marshalled? b))))) + + (define (save) (raw-save #f)) ;; raw-save : boolean -> boolean ;; input determines if there is a dialog box showing the errors (and other msgs) ;; and result indicates if there was an error (define (raw-save silent?) - (with-handlers ([exn:fail? + (with-handlers ([(lambda (x) #f) ;exn:fail? (lambda (exn) (unless silent? (message-box @@ -299,23 +246,18 @@ (format (string-constant pref-lock-not-gone) filename)))))))) res))) - (define (marshall-pref p ht-value) - (cond - [(marshalled? ht-value) (list p (marshalled-data ht-value))] - [(pref? ht-value) - (let* ([value (pref-value ht-value)] - [marshalled - (let/ec k - (guard "marshalling" p value - (lambda () - ((un/marshall-marshall - (hash-table-get marshall-unmarshall p - (lambda () - (k value)))) - value))))]) - (list p marshalled))] - [else (error 'prefs.ss "robby error.2: ~a" ht-value)])) - + ;; marshall-pref : symbol any -> (list symbol printable) + (define (marshall-pref p value) + (if (marshalled? value) + (list p (marshalled-data value)) + (let/ec k + (let* ([marshaller + (un/marshall-marshall + (hash-table-get marshall-unmarshall p + (lambda () (k (list p value)))))] + [marshalled (marshaller value)]) + (list p marshalled))))) + (define (read-err input msg) (message-box (string-constant preferences) @@ -332,12 +274,44 @@ (string-constant error-reading-preferences) "\n" msg + "\n" s2)))) + + ;; read : -> void + (define (-read) (get-disk-prefs/install void)) + + ;; get-disk-prefs/install : (-> A) -> (union A sexp) + (define (get-disk-prefs/install fail) + (let/ec k + (let ([sexp (get-disk-prefs (lambda () (k (fail))))]) + (install-stashed-preferences sexp '()) + sexp))) + ;; get-disk-prefs : (-> A) -> (union A sexp) + ;; effect: updates the flag for the modified seconds + ;; (note: if this is not followed by actually installing + ;; the preferences, things break) + (define (get-disk-prefs fail) + (let/ec k + (let* ([filename (find-system-path 'pref-file)] + [mod (and (file-exists? filename) (file-or-directory-modify-seconds filename))] + [sexp (get-preference main-preferences-symbol (lambda () (k (fail))))]) + sexp))) + + ;; install-stashed-preferences : sexp (listof symbol) -> void + ;; ensure that `prefs' is actuall a well-formed preferences + ;; table and installs them as the current preferences. + (define (install-stashed-preferences prefs skip) + (for-each-pref-in-sexp + prefs + (lambda (p marshalled) + (unless (memq p skip) + (hash-table-put! preferences p (make-marshalled marshalled)))))) + (define (for-each-pref-in-file parse-pref preferences-filename) (let/ec k (let ([input (with-handlers - ([exn:fail? + ([(lambda (x) #f) ;exn:fail? (lambda (exn) (message-box (string-constant error-reading-preferences) @@ -360,64 +334,11 @@ (pair? (cdr pre-pref)) (null? (cddr pre-pref))) (parse-pref (car pre-pref) (cadr pre-pref)) - (begin (read-err input (string-constant expected-list-of-length2)) + (begin (read-err pre-pref (string-constant expected-list-of-length2)) (k #f)))) (loop (cdr input)))))) - - ;; add-raw-pref-to-ht : hash-table symbol marshalled-preference -> void - (define (add-raw-pref-to-ht ht p marshalled) - (let* ([ht-pref (hash-table-get ht p (lambda () #f))] - [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) - (cond - [unmarshall-struct - (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))] - - ;; in this case, assume that no marshalling/unmarshalling - ;; is going to take place with the pref, since an unmarshalled - ;; pref was already there. - [(pref? ht-pref) - (set p marshalled)] - - [(marshalled? ht-pref) - (set-marshalled-data! ht-pref marshalled)] - [(and (not ht-pref) unmarshall-struct) - (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))] - [(not ht-pref) - (hash-table-put! ht p (make-marshalled marshalled))] - [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))) - ;; read : -> void - (define (-read) (get-disk-prefs/install void)) - - ;; get-disk-prefs/install : (-> A) -> (union A sexp) - (define (get-disk-prefs/install fail) - (let/ec k - (let ([sexp (get-disk-prefs (lambda () (k (fail))))]) - (install-stashed-preferences sexp '()) - (reset-changed) - sexp))) - ;; get-disk-prefs : (-> A) -> (union A sexp) - ;; effect: updates the flag for the modified seconds - ;; (note: if this is not followed by actually installing - ;; the preferences, things break) - (define (get-disk-prefs fail) - (let/ec k - (let* ([filename (find-system-path 'pref-file)] - [mod (and (file-exists? filename) (file-or-directory-modify-seconds filename))] - [sexp (get-preference main-preferences-symbol (lambda () (k (fail))))]) - (set! last-time-read mod) - sexp))) - - ;; install-stashed-preferences : sexp (listof symbol) -> void - ;; ensure that `prefs' is actuall a well-formed preferences - ;; table and installs them as the current preferences. - (define (install-stashed-preferences prefs skip) - (for-each-pref-in-sexp - prefs - (lambda (p marshalled) - (unless (memq p skip) - (add-raw-pref-to-ht preferences p marshalled))))) ;; ; ;;; diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index f1868ed7..e482da43 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -184,7 +184,6 @@ save read restore-defaults - start-writing-timer add-panel add-font-panel diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 5adafbb1..f6ad506c 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -9,7 +9,7 @@ WARNING: printf is rebound in the body of the unit to always (require (lib "string-constant.ss" "string-constants") (lib "unitsig.ss") (lib "class.ss") - (lib "plt-match.ss") + (lib "match.ss") "sig.ss" "../macro.ss" "../gui-utils.ss" @@ -856,8 +856,8 @@ WARNING: printf is rebound in the body of the unit to always get-err-port get-value-port)) - (define-struct peeker (bytes skip-count pe resp-chan)) - (define-struct peeker-req (bytes skip-count pe resp-chan resp-nack)) + (define-struct peeker (bytes skip-count pe resp-chan nack)) + (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) (define ports-mixin (mixin ((class->interface text%) #;scheme:text<%>) (ports<%>) @@ -1118,7 +1118,7 @@ WARNING: printf is rebound in the body of the unit to always ;; in any thread (even concurrently) ;; (define (make-write-bytes-proc style) - (lambda (to-write start end block/buffer?) + (lambda (to-write start end block/buffer? enable-breaks?) (cond [(eq? (current-thread) (eventspace-handler-thread eventspace)) (error 'write-bytes-proc "cannot write to port on eventspace main thread")] @@ -1252,70 +1252,35 @@ WARNING: printf is rebound in the body of the unit to always (apply choice-evt (map - (lambda (committer) - (match (make-committer kr - commit-peeker-evt - done-evt - resp-chan - resp-nack) - (choice-evt - (handle-evt - commit-peeker-evt - (lambda (_) - ;; this committer will be thrown out in next iteration - (loop))) - (handle-evt - done-evt - (lambda (v) - (set! data (drop-some-data data)) - (semaphore-post peeker-sema) - (set! peeker-sema (make-semaphore 0)) - (set! peeker-evt (semaphore-peek-evt peeker-sema)) - (set! committers (remq committer committers)) - (set! resp-evts - (cons - (choice-evt - resp-nack - (channel-put-evt resp-chan #t)) - resp-evts)) - (loop)))))) - committers)) - (apply - choice-evt - (map - (lambda (committer) - (match (make-committer kr commit-peeker-evt - done-evt resp-chan resp-nack) - (let ([size (queue-size data)]) - (cond - [(not (eq? peeker-evt commit-peeker-evt)) - (set! resp-evts - (cons - (choice-evt - resp-nack - (channel-put-evt resp-chan #f)) - resp-evts)) - (loop)] - [(< size kr) - (set! resp-evts - (cons - (choice-evt - resp-nack - (channel-put-evt resp-chan 'commit-failure)) - resp-evts)) - (loop)] - [else ;; commit succeeds + (lambda (a-committer) + (match a-committer + [($ committer + kr + commit-peeker-evt + done-evt + resp-chan + resp-nack) + (choice-evt + (handle-evt + commit-peeker-evt + (lambda (_) + ;; this committer will be thrown out in next iteration + (loop))) + (handle-evt + done-evt + (lambda (v) + (set! data (dequeue-n kr data)) (semaphore-post peeker-sema) (set! peeker-sema (make-semaphore 0)) (set! peeker-evt (semaphore-peek-evt peeker-sema)) - (set! data (dequeue-n kr data)) - (set! resp-evts + (set! committers (remq a-committer committers)) + (set! response-evts (cons (choice-evt resp-nack (channel-put-evt resp-chan #t)) - resp-evts)) - (loop)])))) + response-evts)) + (loop))))])) committers)) (apply choice-evt (map (lambda (resp-evt) @@ -1336,7 +1301,7 @@ WARNING: printf is rebound in the body of the unit to always [(null? eles) (values left-alone transformed)] [else (let* ([ele (car eles)] [maybe (f ele)]) - (if maybe-evt + (if maybe (loop (cdr eles) (cons maybe transformed) left-alone) @@ -1347,49 +1312,47 @@ WARNING: printf is rebound in the body of the unit to always ;; service-committer : queue evt -> committer -> (union #f evt) ;; if the committer can be dumped, return an evt that ;; does the dumping. otherwise, return #f - (define ((service-committer data peeker-evt) committer) - (match (make-committer kr commit-peeker-evt - done-evt resp-chan resp-nack) - (let ([size (queue-size data)]) - (cond - [(not (eq? peeker-evt commit-peeker-evt)) - (choice-evt - resp-nack - (channel-put-evt resp-chan #f))] - [(< size kr) - (choice-evt - resp-nack - (channel-put-evt resp-chan 'commit-failure))] - [else ;; commit succeeds - #f])))) + (define ((service-committer data peeker-evt) a-committer) + (match a-committer + [($ committer + kr commit-peeker-evt + done-evt resp-chan resp-nack) + (let ([size (queue-size data)]) + (cond + [(not (eq? peeker-evt commit-peeker-evt)) + (choice-evt + resp-nack + (channel-put-evt resp-chan #f))] + [(< size kr) + (choice-evt + resp-nack + (channel-put-evt resp-chan 'commit-failure))] + [else ;; commit succeeds + #f]))])) ;; service-waiter : peeker -> (union #f evt) ;; if the peeker can be serviced, build an event to service it ;; otherwise return #f - (define (service-waiter peeker) - (let* ([bytes (peeker-bytes peeker)] - [skip-count (peeker-count peeker)] - [pe (peeker-pe peeker)] - [resp-chan (peeker-resp-chan peeker)] - [nack-evt (peeker-nack-evt peeker)] - (cond - [(not (eq? pe peeker-evt)) - (choice-evt (make-channel-put-evt resp-chan #f) - nack-evt)] - [(queue-has-n? data (+ skip-count 1)) - (let ([nth (queue-nth data (+ skip-count 1))]) - (choice-evt - nack-evt - (if (byte? nth) - (begin - (byte-set! bytes 0 fst) - (make-channel-put-evt resp-chan 1)) - (build-answer-evt - (make-channel-put-evt - resp-chan - (lambda (src line col pos) - nth))))))] - [else #f])))) + (define (service-waiter a-peeker) + (match a-peeker + [($ peeker bytes skip-count pe resp-chan nack-evt) + (cond + [(not (eq? pe peeker-evt)) + (choice-evt (channel-put-evt resp-chan #f) + nack-evt)] + [((queue-size data) . > . skip-count) + (let ([nth (peek-n data (+ skip-count 1))]) + (choice-evt + nack-evt + (if (byte? nth) + (begin + (bytes-set! bytes 0 nth) + (channel-put-evt resp-chan 1)) + (channel-put-evt + resp-chan + (lambda (src line col pos) + nth)))))] + [else #f])])) (loop)))) @@ -1466,6 +1429,29 @@ WARNING: printf is rebound in the body of the unit to always (loop (send snip next))))] [else null]))) + ;; dequeue-n : queue number -> queue + (define (dequeue-n queue n) + (let loop ([q queue] + [n n]) + (cond + [(zero? n) queue] + [(queue-empty? q) (error 'dequeue-n "not enough!")] + [else (loop (queue-rest q) (- n 1))]))) + + ;; peek-n : queue number -> queue + (define (peek-n queue n) + (let loop ([q queue] + [n n]) + (cond + [(zero? n) + (when (queue-empty? q) + (error 'peek-n "not enough!")) + (queue-first q)] + [else + (when (queue-empty? q) + (error 'dequeue-n "not enough!")) + (loop (queue-rest q) (- n 1))]))) + ;; split-queue : converter (queue (cons (union snip bytes) style) ;; -> (values (listof (queue (cons (union snip bytes) style)) queue) ;; this function must only be called on the output-buffer-thread diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss index 10a4e89a..bb922b6c 100644 --- a/collects/tests/framework/framework-test-engine.ss +++ b/collects/tests/framework/framework-test-engine.ss @@ -47,7 +47,7 @@ (write (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))]) (if (null? these-errs) - (with-handlers ([not-break-exn? + (with-handlers ([(lambda (x) #t) (lambda (x) (list 'error (exception->string x)))]) (list 'normal (print-convert (eval sexp)))) (list 'last-error diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index d3e4b494..19a17053 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -10,7 +10,7 @@ (define preferences-file (find-system-path 'pref-file)) (define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)]) - (build-path base (string-append name ".save")))) + (build-path base (string-append (path->string name) ".save")))) (define all-files diff --git a/collects/tests/framework/prefs.ss b/collects/tests/framework/prefs.ss index 7a1ae512..ec5facdf 100644 --- a/collects/tests/framework/prefs.ss +++ b/collects/tests/framework/prefs.ss @@ -3,70 +3,95 @@ (lib "etc.ss") (lib "list.ss")) - -(local [(define pref-file (build-path (find-system-path 'pref-dir) - (case (system-type) - [(macos) "MrEd Preferences"] - [(windows) "mred.pre"] - [(unix) ".mred.prefs"] - [else (error 'prefs.ss "unknown os: ~a~n" (system-type))]))) - (define old-prefs (if (file-exists? pref-file) - (call-with-input-file pref-file read) - null)) - (define (check-eq? s) (lambda (t) (eq? s t))) - (define pref-sym 'framework:test-suite)] - - (call-with-output-file pref-file - (lambda (port) (write (filter (lambda (x) (not (eq? (car x) pref-sym))) - old-prefs) - port)) - 'truncate) + (define ((check-eq? x) y) (eq? x y)) + (define pref-sym 'plt:not-a-real-preference) + (define marshalling-pref-sym 'plt:not-a-real-preference-marshalling) + + (define saved-prefs-file + (let loop ([n 0]) + (let ([candidate + (build-path (this-expression-source-directory) + (format "save-prefs.~a" n))]) + (if (file-exists? candidate) + (loop (+ n 1)) + candidate)))) + + (define prefs-file (find-system-path 'pref-file)) + + (when (file-exists? prefs-file) + (copy-file prefs-file saved-prefs-file) + (delete-file prefs-file) + (printf "saved preferences file from ~s to ~s\n" prefs-file saved-prefs-file)) + (shutdown-mred) - + (test 'preference-unbound (check-eq? 'passed) `(with-handlers ([exn:unknown-preference? - (lambda (x) - 'passed)]) + (lambda (x) + 'passed)]) (preferences:get ',pref-sym))) (test 'preference-set-default/get - (check-eq? 'passed) - `(begin (preferences:set-default ',pref-sym 'passed symbol?) - (preferences:get ',pref-sym))) + (check-eq? 'passed) + `(begin (preferences:set-default ',pref-sym 'passed symbol?) + (preferences:get ',pref-sym))) (test 'preference-set/get - (check-eq? 'new-pref) - `(begin (preferences:set ',pref-sym 'new-pref) - (preferences:get ',pref-sym))) + (check-eq? 'new-pref) + `(begin (preferences:set ',pref-sym 'new-pref) + (preferences:get ',pref-sym))) + (test 'preference-marshalling + (check-eq? 'the-answer) + `(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?) + (preferences:set-un/marshall ',marshalling-pref-sym + (lambda (f) (f)) + (lambda (v) (lambda () v))) + (begin0 ((preferences:get ',marshalling-pref-sym)) + (preferences:set ',marshalling-pref-sym (lambda () 2)) + (preferences:save)))) + (shutdown-mred) + (test 'preference-marshalling + (check-eq? 2) + `(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?) + (preferences:set-un/marshall ',marshalling-pref-sym + (lambda (f) (f)) + (lambda (v) (lambda () v))) + ((preferences:get ',marshalling-pref-sym)))) + (with-handlers ([eof-result? (lambda (x) (void))]) (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f) - (exit:exit) - - ;; do this yield here so that exit:exit - ;; actually exits on this interaction. - ;; right now, exit:exit queue's a new event to exit - ;; instead of just exiting immediately. - (yield (make-semaphore 0))))) - + (exit:exit) + + ;; do this yield here so that exit:exit + ;; actually exits on this interaction. + ;; right now, exit:exit queue's a new event to exit + ;; instead of just exiting immediately. + (yield (make-semaphore 0))))) + (test 'preference-get-after-restart - (check-eq? 'new-pref) - `(begin (preferences:set-default ',pref-sym 'passed symbol?) - (preferences:get ',pref-sym)))) - - -(test 'dialog-appears - (lambda (x) (eq? 'passed x)) - (lambda () - (send-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t) - (preferences:show-dialog))) - (wait-for-frame "Preferences") - (send-sexp-to-mred '(begin (preferences:hide-dialog) - (let ([f (get-top-level-focus-window)]) - (if f - (if (string=? "Preferences" (send f get-label)) - 'failed - 'passed) - 'passed)))))) -) + (check-eq? 'new-pref) + `(begin (preferences:set-default ',pref-sym 'passed symbol?) + (preferences:get ',pref-sym))) + + (test 'dialog-appears + (lambda (x) (eq? 'passed x)) + (lambda () + (send-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t) + (preferences:show-dialog))) + (wait-for-frame "Preferences") + (send-sexp-to-mred '(begin (preferences:hide-dialog) + (let ([f (get-top-level-focus-window)]) + (if f + (if (string=? "Preferences" (send f get-label)) + 'failed + 'passed) + 'passed)))))) + + (when (file-exists? saved-prefs-file) + (printf "restoring preferences file from ~s to ~s\n" saved-prefs-file prefs-file) + (when (file-exists? prefs-file) + (delete-file prefs-file)) + (copy-file saved-prefs-file prefs-file) + (delete-file saved-prefs-file))) diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss index f73e77b7..dfa343b6 100644 --- a/collects/tests/framework/test-suite-utils.ss +++ b/collects/tests/framework/test-suite-utils.ss @@ -67,7 +67,7 @@ (define listener (let loop () (let ([port (load port-filename)]) - (with-handlers ([not-break-exn? + (with-handlers ([exn:fail? (lambda (x) (let ([next (+ port 1)]) (call-with-output-file port-filename @@ -87,32 +87,23 @@ (define (restart-mred) (shutdown-mred) (case (system-type) - [(macos) (system* - (mred-program-launcher-path - (if (use-3m) - "Framework Test Engine3m" - "Framework Test Engine")))] [(macosx) (thread (lambda () (system* - (build-path (collection-path "mzlib") - 'up - 'up - "bin" - (if (use-3m) - "mred3m" - "mred")) + (path->string + (build-path (collection-path "mzlib") + 'up + 'up + "bin" + (if (use-3m) + "mred3m" + "mred"))) "-mvqt" - (build-path (collection-path "tests" "framework") - "framework-test-engine.ss"))))] - [else (thread - (lambda () - (system* - (mred-program-launcher-path - (if (use-3m) - "Framework Test Engine3m" - "Framework Test Engine")))))]) + (path->string + (build-path (collection-path "tests" "framework") + "framework-test-engine.ss")))))] + [else (error 'test-suite-utils.ss "don't know how to start mred")]) (debug-printf mz-tcp "accepting listener~n") (let-values ([(in out) (tcp-accept listener)]) (set! in-port in) @@ -141,9 +132,9 @@ (lambda () (when (and in-port out-port) - (with-handlers ([not-break-exn? (lambda (x) (void))]) + (with-handlers ([exn:fail? (lambda (x) (void))]) (close-output-port out-port)) - (with-handlers ([not-break-exn? (lambda (x) (void))]) + (with-handlers ([exn:fail? (lambda (x) (void))]) (close-input-port in-port)) (set! in-port #f) (set! in-port #f)))) @@ -196,7 +187,7 @@ (restart-mred)) (debug-printf messages " ~a // ~a: sending to mred:~n" section-name test-name) (show-text sexp) - (with-handlers ([not-break-exn? + (with-handlers ([exn:fail? (lambda (x) (cond ;; this means that mred was closed @@ -209,7 +200,7 @@ (write sexp out-port) (newline out-port)) (let ([answer - (with-handlers ([not-break-exn? + (with-handlers ([exn:fail? (lambda (x) (if (tcp-error? x);; assume tcp-error means app closed eof @@ -256,7 +247,7 @@ (when (or (not only-these-tests) (memq test-name only-these-tests)) (let* ([result - (with-handlers ([not-break-exn? + (with-handlers ([exn:fail? (lambda (x) (if (exn? x) (exn-message x) @@ -265,7 +256,7 @@ (sexp/proc) (begin0 (send-sexp-to-mred sexp/proc) (send-sexp-to-mred ''check-for-errors))))] - [failed (with-handlers ([not-break-exn? + [failed (with-handlers ([exn:fail? (lambda (x) (string-append "passed? test raised exn: "