From 55619b853eee2430cc48e7593629b05fc8682202 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 9 Jul 2006 05:32:41 +0000 Subject: [PATCH] * made quiet.ss show real errors properly (tricky...) * the exit code of quiet.ss is now 1 for failed tests, 2 for an unexpected error, and 3 for a timeout * added net.ss and uni-norm.ss to all.ss * uni-norm.ss will retrieve the test file if it doesn't find it * it will also throw an error if it cannot retrieve proper tests svn: r3662 --- collects/tests/mzscheme/all.ss | 2 ++ collects/tests/mzscheme/net.ss | 2 ++ collects/tests/mzscheme/quiet.ss | 29 ++++++++++++--- collects/tests/mzscheme/uni-norm.ss | 56 ++++++++++++++++++++--------- 4 files changed, 68 insertions(+), 21 deletions(-) diff --git a/collects/tests/mzscheme/all.ss b/collects/tests/mzscheme/all.ss index 13397c9dcc..7c80af8435 100644 --- a/collects/tests/mzscheme/all.ss +++ b/collects/tests/mzscheme/all.ss @@ -2,4 +2,6 @@ (load-relative "mz.ss") (load-relative "mzlib.ss") (load-relative "boundmap-test.ss") +(load-relative "net.ss") (load-relative "foreign-test.ss") +(load-relative "uni-norm.ss") diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss index 05d2adfbcd..b71cccd0b1 100644 --- a/collects/tests/mzscheme/net.ss +++ b/collects/tests/mzscheme/net.ss @@ -1,6 +1,8 @@ (load-relative "loadtest.ss") +(Section 'net) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; url.ss tests diff --git a/collects/tests/mzscheme/quiet.ss b/collects/tests/mzscheme/quiet.ss index 4115aec669..8986e5a2e4 100644 --- a/collects/tests/mzscheme/quiet.ss +++ b/collects/tests/mzscheme/quiet.ss @@ -7,13 +7,32 @@ (namespace-variable-value 'real-error-port #f (lambda () - (let ([e (current-error-port)] [ex (exit-handler)] [c (current-custodian)]) - (namespace-set-variable-value! 'real-error-port e) - ;; we're loading this for the first time -- set up a timeout + (let ([err (current-error-port)] + [exit (exit-handler)] + [errh (current-exception-handler)] + [esch (error-escape-handler)] + [cust (current-custodian)]) + (namespace-set-variable-value! 'real-error-port err) + ;; we're loading this for the first time: + ;; -- make real errors show + ;; (can't override current-exception-handler alone, since the escape + ;; handler is overridden to avoid running off, so use the first to + ;; save the data and the second to show it) + (let ([last-error #f]) + (current-exception-handler (lambda (e) (set! last-error e) (errh e))) + (error-escape-handler + (lambda () + (fprintf err "ERROR: ~a\n" + (if (exn? last-error) (exn-message last-error) last-error)) + (exit 2)))) + ;; -- set up a timeout (thread (lambda () - (sleep 600) (fprintf e "\n\nTIMEOUT -- ABORTING!\n") (ex 2) + (sleep 600) + (fprintf err "\n\nTIMEOUT -- ABORTING!\n") + (exit 3) ;; in case the above didn't work for some reason - (sleep 60) (custodian-shutdown-all c)))))) + (sleep 60) + (custodian-shutdown-all cust)))))) (let ([p (make-output-port 'quiet always-evt (lambda (str s e nonblock? breakable?) (- e s)) diff --git a/collects/tests/mzscheme/uni-norm.ss b/collects/tests/mzscheme/uni-norm.ss index a9ce1d178c..52b1dc05a5 100644 --- a/collects/tests/mzscheme/uni-norm.ss +++ b/collects/tests/mzscheme/uni-norm.ss @@ -1,30 +1,54 @@ -(require (lib "string.ss")) +(require (lib "string.ss") + (only (lib "url.ss" "net") get-pure-port string->url) + (only (lib "port.ss") copy-port)) (load-relative "loadtest.ss") +(Section 'uni-norm) + (define (parse-string m) (let ([s (regexp-split #rx" +" m)]) - (apply string (map (lambda (x) (integer->char - (string->number - (bytes->string/latin-1 x) - 16))) - s)))) + (apply string + (map (lambda (x) + (integer->char (string->number (bytes->string/latin-1 x) 16))) + s)))) + +(define (get-test-file) + (define name "NormalizationTest.txt") + (define base "http://www.unicode.org/Public/UNIDATA/") + (define (existing) + (let loop ([dirs (list (current-load-relative-directory) + (current-directory))]) + (and (pair? dirs) + (let ([path (build-path (car dirs) name)]) + (if (file-exists? path) path (loop (cdr dirs))))))) + (define (get-it) + (parameterize ([current-input-port + (get-pure-port (string->url (string-append base name)))]) + (with-output-to-file name + (lambda () (copy-port (current-input-port) (current-output-port))) + 'truncate))) + (or (existing) + (begin (get-it) (existing)) + (error "file not found: ~s" file))) (printf "Reading tests...\n") (define test-strings - (with-input-from-file (build-path (current-load-relative-directory) - "NormalizationTest.txt") + (with-input-from-file (get-test-file) (lambda () + (unless (regexp-match #rx"^# NormalizationTest-" (read-line)) + (error "Bad test-file contents (couldn't retreive tests?)")) (let loop ([a null]) (let ([l (read-line)]) (if (eof-object? l) - a - (let ([m (regexp-match #rx#"^([0-9A-F ]+);([0-9A-F ]+);([0-9A-F ]+);([0-9A-F ]+);([0-9A-F ]+)" l)]) - (if m - (loop (cons (cons l (map parse-string (cdr m))) - a)) - (loop a))))))))) + (if (null? a) + (error "No tests found (couldn't retreive tests?)") + (reverse! a)) + (let ([m (regexp-match #rx#"^([0-9A-F ]+);([0-9A-F ]+);([0-9A-F ]+);([0-9A-F ]+);([0-9A-F ]+)" l)]) + (if m + (loop (cons (cons l (map parse-string (cdr m))) a)) + (loop a))))))))) (for-each (lambda (l) @@ -36,7 +60,7 @@ (test c2 string-normalize-nfc c3) (test c4 string-normalize-nfc c4) (test c4 string-normalize-nfc c5) - + (test c3 string-normalize-nfd c1) (test c3 string-normalize-nfd c2) (test c3 string-normalize-nfd c3) @@ -56,4 +80,4 @@ (test c5 string-normalize-nfkd c5))) test-strings) -(report-errs) \ No newline at end of file +(report-errs)