* 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,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")

collects/tests/mzscheme/net.ss

@@ -1,6 +1,8 @@
 
 (load-relative "loadtest.ss")
 
+(Section 'net)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; url.ss tests

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

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)
+(report-errs)